Theory Base

(* Title:      Base
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Base›

theory Base

imports Stone_Relation_Algebras.Semirings

begin

class while =
  fixes while :: "'a ⇒ 'a ⇒ 'a" (infixr "⋆" 59)

class n =
  fixes n :: "'a ⇒ 'a"

class diamond =
  fixes diamond :: "'a ⇒ 'a ⇒ 'a" ("| _ > _" [50,90] 95)

class box =
  fixes box :: "'a ⇒ 'a ⇒ 'a" ("| _ ] _" [50,90] 95)

context ord
begin

definition ascending_chain :: "(nat ⇒ 'a) ⇒ bool"
  where "ascending_chain f ≡ ∀n . f n ≤ f (Suc n)"

definition descending_chain :: "(nat ⇒ 'a) ⇒ bool"
  where "descending_chain f ≡ ∀n . f (Suc n) ≤ f n"

definition directed :: "'a set ⇒ bool"
  where "directed X ≡ X ≠ {} ∧ (∀x∈X . ∀y∈X . ∃z∈X . x ≤ z ∧ y ≤ z)"

definition co_directed :: "'a set ⇒ bool"
  where "co_directed X ≡ X ≠ {} ∧ (∀x∈X . ∀y∈X . ∃z∈X . z ≤ x ∧ z ≤ y)"

definition chain :: "'a set ⇒ bool"
  where "chain X ≡ ∀x∈X . ∀y∈X . x ≤ y ∨ y ≤ x"

end

context order
begin

lemma ascending_chain_k:
  "ascending_chain f ⟹ f m ≤ f (m + k)"
  apply (induct k)
  apply simp
  using le_add1 lift_Suc_mono_le ord.ascending_chain_def by blast

lemma ascending_chain_isotone:
  "ascending_chain f ⟹ m ≤ k ⟹ f m ≤ f k"
  using lift_Suc_mono_le ord.ascending_chain_def by blast

lemma ascending_chain_comparable:
  "ascending_chain f ⟹ f k ≤ f m ∨ f m ≤ f k"
  by (meson ascending_chain_isotone linear)

lemma ascending_chain_chain:
  "ascending_chain f ⟹ chain (range f)"
  by (simp add: ascending_chain_comparable chain_def)

lemma chain_directed:
  "X ≠ {} ⟹ chain X ⟹ directed X"
  by (metis chain_def directed_def)

lemma ascending_chain_directed:
  "ascending_chain f ⟹ directed (range f)"
  by (simp add: ascending_chain_chain chain_directed)

lemma descending_chain_k:
  "descending_chain f ⟹ f (m + k) ≤ f m"
  apply (induct k)
  apply simp
  using le_add1 lift_Suc_antimono_le ord.descending_chain_def by blast

lemma descending_chain_antitone:
  "descending_chain f ⟹ m ≤ k ⟹ f k ≤ f m"
  using descending_chain_def lift_Suc_antimono_le by blast

lemma descending_chain_comparable:
  "descending_chain f ⟹ f k ≤ f m ∨ f m ≤ f k"
  by (meson descending_chain_antitone nat_le_linear)

lemma descending_chain_chain:
  "descending_chain f ⟹ chain (range f)"
  by (simp add: descending_chain_comparable chain_def)

lemma chain_co_directed:
  "X ≠ {} ⟹ chain X ⟹ co_directed X"
  by (metis chain_def co_directed_def)

lemma descending_chain_codirected:
  "descending_chain f ⟹ co_directed (range f)"
  by (simp add: chain_co_directed descending_chain_chain)

end

context semilattice_sup
begin

lemma ascending_chain_left_sup:
  "ascending_chain f ⟹ ascending_chain (λn . x ⊔ f n)"
  using ascending_chain_def sup_right_isotone by blast

lemma ascending_chain_right_sup:
  "ascending_chain f ⟹ ascending_chain (λn . f n ⊔ x)"
  using ascending_chain_def sup_left_isotone by auto

lemma descending_chain_left_add:
  "descending_chain f ⟹ descending_chain (λn . x ⊔ f n)"
  using descending_chain_def sup_right_isotone by blast

lemma descending_chain_right_add:
  "descending_chain f ⟹ descending_chain (λn . f n ⊔ x)"
  using descending_chain_def sup_left_isotone by auto

primrec pSum0 :: "(nat ⇒ 'a) ⇒ nat ⇒ 'a"
  where "pSum0 f 0 = f 0"
      | "pSum0 f (Suc m) = pSum0 f m ⊔ f m"

lemma pSum0_below:
 "∀i . f i ≤ x ⟹ pSum0 f m ≤ x"
  apply (induct m)
  by auto

end

context non_associative_left_semiring
begin

lemma ascending_chain_left_mult:
  "ascending_chain f ⟹ ascending_chain (λn . x * f n)"
  by (simp add: mult_right_isotone ord.ascending_chain_def)

lemma ascending_chain_right_mult:
  "ascending_chain f ⟹ ascending_chain (λn . f n * x)"
  by (simp add: mult_left_isotone ord.ascending_chain_def)

lemma descending_chain_left_mult:
  "descending_chain f ⟹ descending_chain (λn . x * f n)"
  by (simp add: descending_chain_def mult_right_isotone)

lemma descending_chain_right_mult:
  "descending_chain f ⟹ descending_chain (λn . f n * x)"
  by (simp add: descending_chain_def mult_left_isotone)

end

context complete_lattice
begin

lemma sup_Sup:
  "A ≠ {} ⟹ sup x (Sup A) = Sup ((sup x) ` A)"
  apply (rule order.antisym)
  apply (meson ex_in_conv imageI SUP_upper2 Sup_mono sup.boundedI sup_left_divisibility sup_right_divisibility)
  by (meson SUP_least Sup_upper sup_right_isotone)

lemma sup_SUP:
  "Y ≠ {} ⟹ sup x (SUP y∈Y . f y) = (SUP y∈Y. sup x (f y))"
  apply (subst sup_Sup)
  by (simp_all add: image_image)

lemma inf_Inf:
  "A ≠ {} ⟹ inf x (Inf A) = Inf ((inf x) ` A)"
  apply (rule order.antisym)
  apply (meson INF_greatest Inf_lower inf.sup_right_isotone)
  by (simp add: INF_inf_const1)

lemma inf_INF:
  "Y ≠ {} ⟹ inf x (INF y∈Y . f y) = (INF y∈Y. inf x (f y))"
  apply (subst inf_Inf)
  by (simp_all add: image_image)

lemma SUP_image_id[simp]:
  "(SUP x∈f`A . x) = (SUP x∈A . f x)"
  by simp

lemma INF_image_id[simp]:
  "(INF x∈f`A . x) = (INF x∈A . f x)"
  by simp

end

lemma image_Collect_2:
  "f ` { g x | x . P x } = { f (g x) | x . P x }"
  by auto

text ‹The following instantiation and four lemmas are from Jose Divason Mallagaray.›

instantiation "fun" :: (type, type) power
begin

definition one_fun :: "'a ⇒ 'a"
  where one_fun_def: "one_fun ≡ id"

definition times_fun :: "('a ⇒ 'a) ⇒ ('a ⇒ 'a) ⇒ ('a ⇒ 'a)"
  where times_fun_def: "times_fun ≡ comp"

instance
  by intro_classes

end

lemma id_power:
  "id^m = id"
  apply (induct m)
  apply (simp add: one_fun_def)
  by (simp add: times_fun_def)

lemma power_zero_id:
  "f^0 = id"
  by (simp add: one_fun_def)

lemma power_succ_unfold:
  "f^Suc m = f ∘ f^m"
  by (simp add: times_fun_def)

lemma power_succ_unfold_ext:
  "(f^Suc m) x = f ((f^m) x)"
  by (simp add: times_fun_def)

end

Theory Omega_Algebras

(* Title:      Omega Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Omega Algebras›

theory Omega_Algebras

imports Stone_Kleene_Relation_Algebras.Kleene_Algebras

begin

class omega =
  fixes omega :: "'a ⇒ 'a" ("_⇧^ω" [100] 100)

class left_omega_algebra = left_kleene_algebra + omega +
  assumes omega_unfold: "y⇧^ω = y * y⇧^ω"
  assumes omega_induct: "x ≤ z ⊔ y * x ⟶ x ≤ y⇧^ω ⊔ y⇧^⋆ * z"
begin

text ‹Many lemmas in this class are taken from Georg Struth's Isabelle theories.›

lemma star_bot_below_omega:
  "x⇧^⋆ * bot ≤ x⇧^ω"
  using omega_unfold star_left_induct_equal by auto

lemma star_bot_below_omega_bot:
  "x⇧^⋆ * bot ≤ x⇧^ω * bot"
  by (metis omega_unfold star_left_induct_equal sup_monoid.add_0_left mult_assoc)

lemma omega_induct_mult:
  "y ≤ x * y ⟹ y ≤ x⇧^ω"
  by (metis bot_least omega_induct sup.absorb1 sup.absorb2 star_bot_below_omega)

lemma omega_sub_dist:
  "x⇧^ω ≤ (x ⊔ y)⇧^ω"
  by (metis eq_refl mult_isotone omega_unfold sup.cobounded1 omega_induct_mult)

lemma omega_isotone:
  "x ≤ y ⟹ x⇧^ω ≤ y⇧^ω"
  using sup_left_divisibility omega_sub_dist by fastforce

lemma omega_induct_equal:
  "y = z ⊔ x * y ⟹ y ≤ x⇧^ω ⊔ x⇧^⋆ * z"
  by (simp add: omega_induct)

lemma omega_bot:
  "bot⇧^ω = bot"
  by (metis mult_left_zero omega_unfold)

lemma omega_one_greatest:
  "x ≤ 1⇧^ω"
  by (simp add: omega_induct_mult)

lemma star_mult_omega:
  "x⇧^⋆ * x⇧^ω = x⇧^ω"
  by (metis order.antisym omega_unfold star.circ_loop_fixpoint star_left_induct_mult_equal sup.cobounded2)

lemma omega_sub_vector:
  "x⇧^ω * y ≤ x⇧^ω"
  by (metis mult_semi_associative omega_unfold omega_induct_mult)

lemma omega_simulation:
  "z * x ≤ y * z ⟹ z * x⇧^ω ≤ y⇧^ω"
  by (smt (verit, ccfv_threshold) mult_isotone omega_unfold order_lesseq_imp mult_assoc omega_induct_mult)

lemma omega_omega:
  "x⇧^ω⇧^ω ≤ x⇧^ω"
  by (metis omega_unfold omega_sub_vector)

lemma left_plus_omega:
  "(x * x⇧^⋆)⇧^ω = x⇧^ω"
  by (metis order.antisym mult_assoc omega_induct_mult omega_unfold order_refl star.left_plus_circ star_mult_omega)

lemma omega_slide:
  "x * (y * x)⇧^ω = (x * y)⇧^ω"
  by (metis order.antisym mult_assoc mult_right_isotone omega_simulation omega_unfold order_refl)

lemma omega_simulation_2:
  "y * x ≤ x * y ⟹ (x * y)⇧^ω ≤ x⇧^ω"
  by (metis mult_right_isotone sup.absorb2 omega_induct_mult omega_slide omega_sub_dist)

lemma wagner:
  "(x ⊔ y)⇧^ω = x * (x ⊔ y)⇧^ω ⊔ z ⟹ (x ⊔ y)⇧^ω = x⇧^ω ⊔ x⇧^⋆ * z"
  by (smt (verit, ccfv_SIG) order.refl star_left_induct sup.absorb2 sup_assoc sup_commute omega_induct_equal omega_sub_dist)

lemma right_plus_omega:
  "(x⇧^⋆ * x)⇧^ω = x⇧^ω"
  by (metis left_plus_omega omega_slide star_mult_omega)

lemma omega_sub_dist_1:
  "(x * y⇧^⋆)⇧^ω ≤ (x ⊔ y)⇧^ω"
  by (metis left_plus_omega mult_isotone star.circ_sub_dist sup.cobounded1 sup_monoid.add_commute omega_isotone)

lemma omega_sub_dist_2:
  "(x⇧^⋆ * y)⇧^ω ≤ (x ⊔ y)⇧^ω"
  by (metis mult_isotone star.circ_sub_dist sup.cobounded2 omega_isotone right_plus_omega)

lemma omega_star:
  "(x⇧^ω)⇧^⋆ = 1 ⊔ x⇧^ω"
  by (metis antisym_conv star.circ_mult_increasing star_left_unfold_equal omega_sub_vector)

lemma omega_mult_omega_star:
  "x⇧^ω * x⇧^ω⇧^⋆ = x⇧^ω"
  by (simp add: order.antisym star.circ_mult_increasing omega_sub_vector)

lemma omega_sum_unfold_1:
  "(x ⊔ y)⇧^ω = x⇧^ω ⊔ x⇧^⋆ * y * (x ⊔ y)⇧^ω"
  by (metis mult_right_dist_sup omega_unfold mult_assoc wagner)

lemma omega_sum_unfold_2:
  "(x ⊔ y)⇧^ω ≤ (x⇧^⋆ * y)⇧^ω ⊔ (x⇧^⋆ * y)⇧^⋆ * x⇧^ω"
  using omega_induct_equal omega_sum_unfold_1 by auto

lemma omega_sum_unfold_3:
  "(x⇧^⋆ * y)⇧^⋆ * x⇧^ω ≤ (x ⊔ y)⇧^ω"
  using star_left_induct_equal omega_sum_unfold_1 by auto

lemma omega_decompose:
  "(x ⊔ y)⇧^ω = (x⇧^⋆ * y)⇧^ω ⊔ (x⇧^⋆ * y)⇧^⋆ * x⇧^ω"
  by (metis sup.absorb1 sup_same_context omega_sub_dist_2 omega_sum_unfold_2 omega_sum_unfold_3)

lemma omega_loop_fixpoint:
  "y * (y⇧^ω ⊔ y⇧^⋆ * z) ⊔ z = y⇧^ω ⊔ y⇧^⋆ * z"
  apply (rule order.antisym)
  apply (smt (verit, ccfv_threshold) eq_refl mult_isotone mult_left_sub_dist_sup omega_induct omega_unfold star.circ_loop_fixpoint sup_assoc sup_commute sup_right_isotone)
  by (smt (z3) mult_left_sub_dist_sup omega_unfold star.circ_loop_fixpoint sup.left_commute sup_commute sup_right_isotone)

lemma omega_loop_greatest_fixpoint:
  "y * x ⊔ z = x ⟹ x ≤ y⇧^ω ⊔ y⇧^⋆ * z"
  by (simp add: sup_commute omega_induct_equal)

lemma omega_square:
  "x⇧^ω = (x * x)⇧^ω"
  using order.antisym omega_unfold order_refl mult_assoc omega_induct_mult omega_simulation_2 by auto

lemma mult_bot_omega:
  "(x * bot)⇧^ω = x * bot"
  by (metis mult_left_zero omega_slide)

lemma mult_bot_add_omega:
  "(x ⊔ y * bot)⇧^ω = x⇧^ω ⊔ x⇧^⋆ * y * bot"
  by (metis mult_left_zero sup_commute mult_assoc mult_bot_omega omega_decompose omega_loop_fixpoint)

lemma omega_mult_star:
  "x⇧^ω * x⇧^⋆ = x⇧^ω"
  by (meson antisym_conv star.circ_back_loop_prefixpoint sup.boundedE omega_sub_vector)

lemma omega_loop_is_greatest_fixpoint:
  "is_greatest_fixpoint (λx . y * x ⊔ z) (y⇧^ω ⊔ y⇧^⋆ * z)"
  by (simp add: is_greatest_fixpoint_def omega_loop_fixpoint omega_loop_greatest_fixpoint)

lemma omega_loop_nu:
  "ν (λx . y * x ⊔ z) = y⇧^ω ⊔ y⇧^⋆ * z"
  by (metis greatest_fixpoint_same omega_loop_is_greatest_fixpoint)

lemma omega_loop_bot_is_greatest_fixpoint:
  "is_greatest_fixpoint (λx . y * x) (y⇧^ω)"
  using is_greatest_fixpoint_def omega_unfold omega_induct_mult by auto

lemma omega_loop_bot_nu:
  "ν (λx . y * x) = y⇧^ω"
  by (metis greatest_fixpoint_same omega_loop_bot_is_greatest_fixpoint)

lemma affine_has_greatest_fixpoint:
  "has_greatest_fixpoint (λx . y * x ⊔ z)"
  using has_greatest_fixpoint_def omega_loop_is_greatest_fixpoint by blast

lemma omega_separate_unfold:
  "(x⇧^⋆ * y)⇧^ω = y⇧^ω ⊔ y⇧^⋆ * x * (x⇧^⋆ * y)⇧^ω"
  by (metis star.circ_loop_fixpoint sup_commute mult_assoc omega_slide omega_sum_unfold_1)

lemma omega_bot_left_slide:
  "(x * y)⇧^⋆ * ((x * y)⇧^ω * bot ⊔ 1) * x ≤ x * (y * x)⇧^⋆ * ((y * x)⇧^ω * bot ⊔ 1)"
proof -
  have "x ⊔ x * (y * x) * (y * x)⇧^⋆ * ((y * x)⇧^ω * bot ⊔ 1) ≤ x * (y * x)⇧^⋆ * ((y * x)⇧^ω * bot ⊔ 1)"
    by (metis sup_commute mult_assoc mult_right_isotone star.circ_back_loop_prefixpoint star.mult_zero_sup_circ star.mult_zero_circ le_supE le_supI order.refl star.circ_increasing star.circ_mult_upper_bound)
  hence "((x * y)⇧^ω * bot ⊔ 1) * x ⊔ x * y * (x * (y * x)⇧^⋆ * ((y * x)⇧^ω * bot ⊔ 1)) ≤ x * (y * x)⇧^⋆ * ((y * x)⇧^ω * bot ⊔ 1)"
    by (smt (z3) sup.absorb_iff2 sup_assoc mult_assoc mult_left_one mult_left_sub_dist_sup_left mult_left_zero mult_right_dist_sup omega_slide star_mult_omega)
  thus ?thesis
    by (simp add: star_left_induct mult_assoc)
qed

lemma omega_bot_add_1:
  "(x ⊔ y)⇧^⋆ * ((x ⊔ y)⇧^ω * bot ⊔ 1) = x⇧^⋆ * (x⇧^ω * bot ⊔ 1) * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1)"
proof (rule order.antisym)
  have 1: "(x ⊔ y) * x⇧^⋆ * (x⇧^ω * bot ⊔ 1) * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1) ≤ x⇧^⋆ * (x⇧^ω * bot ⊔ 1) * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1)"
    by (smt (z3) eq_refl star.circ_mult_upper_bound star.circ_sub_dist_1 star.mult_zero_circ star.mult_zero_sup_circ star_sup_1 sup_assoc sup_commute mult_assoc)
  have 2: "1 ≤ x⇧^⋆ * (x⇧^ω * bot ⊔ 1) * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1)"
    using reflexive_mult_closed star.circ_reflexive sup_ge2 by auto
  have "(y * x⇧^⋆)⇧^ω * bot ≤ (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot"
    by (metis mult_1_right mult_left_isotone mult_left_sub_dist_sup_right omega_isotone)
  also have 3: "... ≤ (x⇧^ω * bot ⊔ 1) * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1)"
    by (metis mult_isotone mult_left_one star.circ_reflexive sup_commute sup_ge2)
  finally have 4: "(x⇧^⋆ * y)⇧^ω * bot ≤ x⇧^⋆ * (x⇧^ω * bot ⊔ 1) * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1)"
    by (smt mult_assoc mult_right_isotone omega_slide)
  have "y * (x⇧^⋆ * y)⇧^⋆ * x⇧^ω * bot ≤ y * (x⇧^⋆ * (x⇧^ω * bot ⊔ y))⇧^⋆ * x⇧^⋆ * x⇧^ω * bot * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot"
    using mult_isotone mult_left_sub_dist_sup_left mult_left_zero order.refl star_isotone sup_commute mult_assoc star_mult_omega by auto
  also have "... ≤ y * (x⇧^⋆ * (x⇧^ω * bot ⊔ y))⇧^⋆ * (x⇧^⋆ * (x⇧^ω * bot ⊔ 1) * y)⇧^ω * bot"
    by (smt mult_assoc mult_left_isotone mult_left_sub_dist_sup_left omega_slide)
  also have "... = y * (x⇧^⋆ * (x⇧^ω * bot ⊔ 1) * y)⇧^ω * bot"
    using mult_left_one mult_left_zero mult_right_dist_sup mult_assoc star_mult_omega by auto
  finally have "x⇧^⋆ * y * (x⇧^⋆ * y)⇧^⋆ * x⇧^ω * bot ≤ x⇧^⋆ * (x⇧^ω * bot ⊔ 1) * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1)"
    using 3 by (smt mult_assoc mult_right_isotone omega_slide order_trans)
  hence "(x⇧^⋆ * y)⇧^⋆ * x⇧^ω * bot ≤ x⇧^⋆ * (x⇧^ω * bot ⊔ 1) * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1)"
    by (smt (verit, ccfv_threshold) sup_assoc sup_commute le_iff_sup mult_assoc mult_isotone mult_left_one mult_1_right mult_right_sub_dist_sup_left order_trans star.circ_loop_fixpoint star.circ_reflexive star.mult_zero_circ)
  hence "(x ⊔ y)⇧^ω * bot ≤ x⇧^⋆ * (x⇧^ω * bot ⊔ 1) * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1)"
    using 4 by (smt (z3) mult_right_dist_sup sup.orderE sup_assoc sup_right_divisibility omega_decompose)
  thus "(x ⊔ y)⇧^⋆ * ((x ⊔ y)⇧^ω * bot ⊔ 1) ≤ x⇧^⋆ * (x⇧^ω * bot ⊔ 1) * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1)"
    using 1 2 star_left_induct mult_assoc by force
next
  have 5: "x⇧^ω * bot ≤ (x ⊔ y)⇧^⋆ * ((x ⊔ y)⇧^ω * bot ⊔ 1)"
    by (metis bot_least le_supI1 le_supI2 mult_isotone star.circ_loop_fixpoint sup.cobounded1 omega_isotone)
  have 6: "(y * x⇧^⋆)⇧^ω * bot ≤ (x ⊔ y)⇧^⋆ * ((x ⊔ y)⇧^ω * bot ⊔ 1)"
    by (metis sup_commute mult_left_isotone omega_sub_dist_1 mult_assoc mult_left_sub_dist_sup_left order_trans star_mult_omega)
  have 7: "(y * x⇧^⋆)⇧^⋆ ≤ (x ⊔ y)⇧^⋆"
    by (metis mult_left_one mult_right_sub_dist_sup_left star.circ_sup_1 star.circ_plus_one)
  hence "(y * x⇧^⋆)⇧^⋆ * x⇧^ω * bot ≤ (x ⊔ y)⇧^⋆ * ((x ⊔ y)⇧^ω * bot ⊔ 1)"
    by (smt sup_assoc le_iff_sup mult_assoc mult_isotone mult_right_dist_sup omega_sub_dist)
  hence "(x⇧^ω * bot ⊔ y * x⇧^⋆)⇧^ω * bot ≤ (x ⊔ y)⇧^⋆ * ((x ⊔ y)⇧^ω * bot ⊔ 1)"
    using 6 by (smt sup_commute sup.bounded_iff mult_assoc mult_right_dist_sup mult_bot_add_omega omega_unfold omega_bot)
  hence "(y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ≤ y * x⇧^⋆ * (x ⊔ y)⇧^⋆ * ((x ⊔ y)⇧^ω * bot ⊔ 1)"
    by (smt mult_assoc mult_left_one mult_left_zero mult_right_dist_sup mult_right_isotone omega_slide)
  also have "... ≤ (x ⊔ y)⇧^⋆ * ((x ⊔ y)⇧^ω * bot ⊔ 1)"
    using 7 by (metis mult_left_isotone order_refl star.circ_mult_upper_bound star_left_induct_mult_iff)
  finally have "(y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1) ≤ (x ⊔ y)⇧^⋆ * ((x ⊔ y)⇧^ω * bot ⊔ 1)"
    using 5 by (smt (z3) le_supE star.circ_mult_upper_bound star.circ_sub_dist_1 star.mult_zero_circ star.mult_zero_sup_circ star_involutive star_isotone sup_commute)
  hence "(x⇧^ω * bot ⊔ 1) * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1) ≤ (x ⊔ y)⇧^⋆ * ((x ⊔ y)⇧^ω * bot ⊔ 1)"
    using 5 by (metis sup_commute mult_assoc star.circ_isotone star.circ_mult_upper_bound star.mult_zero_sup_circ star.mult_zero_circ star_involutive)
  thus "x⇧^⋆ * (x⇧^ω * bot ⊔ 1) * (y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^⋆ * ((y * x⇧^⋆ * (x⇧^ω * bot ⊔ 1))⇧^ω * bot ⊔ 1) ≤ (x ⊔ y)⇧^⋆ * ((x ⊔ y)⇧^ω * bot ⊔ 1)"
    by (smt sup_assoc sup_commute mult_assoc star.circ_mult_upper_bound star.circ_sub_dist star.mult_zero_sup_circ star.mult_zero_circ)
qed

lemma star_omega_greatest:
  "x⇧^⋆⇧^ω = 1⇧^ω"
  by (metis sup_commute le_iff_sup omega_one_greatest omega_sub_dist star.circ_plus_one)

lemma omega_vector_greatest:
  "x⇧^ω * 1⇧^ω = x⇧^ω"
  by (metis order.antisym mult_isotone omega_mult_omega_star omega_one_greatest omega_sub_vector)

lemma mult_greatest_omega:
  "(x * 1⇧^ω)⇧^ω ≤ x * 1⇧^ω"
  by (metis mult_right_isotone omega_slide omega_sub_vector)

lemma omega_mult_star_2:
  "x⇧^ω * y⇧^⋆ = x⇧^ω"
  by (meson order.antisym le_supE star.circ_back_loop_prefixpoint omega_sub_vector)

lemma omega_import:
  assumes "p ≤ p * p"
      and "p * x ≤ x * p"
    shows "p * x⇧^ω = p * (p * x)⇧^ω"
proof -
  have "p * x⇧^ω ≤ p * (p * x) * x⇧^ω"
    by (metis assms(1) mult_assoc mult_left_isotone omega_unfold)
  also have "... ≤ p * x * p * x⇧^ω"
    by (metis assms(2) mult_assoc mult_left_isotone mult_right_isotone)
  finally have "p * x⇧^ω ≤ (p * x)⇧^ω"
    by (simp add: mult_assoc omega_induct_mult)
  hence "p * x⇧^ω ≤ p * (p * x)⇧^ω"
    by (metis assms(1) mult_assoc mult_left_isotone mult_right_isotone order_trans)
  thus "p * x⇧^ω = p * (p * x)⇧^ω"
    by (metis assms(2) sup_left_divisibility order.antisym mult_right_isotone omega_induct_mult omega_slide omega_sub_dist)
qed

(*
lemma omega_circ_simulate_right_plus: "z * x ≤ y * (y⇧^ω * bot ⊔ y⇧^⋆) * z ⊔ w ⟶ z * (x⇧^ω * bot ⊔ x⇧^⋆) ≤ (y⇧^ω * bot ⊔ y⇧^⋆) * (z ⊔ w * (x⇧^ω * bot ⊔ x⇧^⋆))" nitpick [expect=genuine,card=4] oops
lemma omega_circ_simulate_left_plus: "x * z ≤ z * (y⇧^ω * bot ⊔ y⇧^⋆) ⊔ w ⟶ (x⇧^ω * bot ⊔ x⇧^⋆) * z ≤ (z ⊔ (x⇧^ω * bot ⊔ x⇧^⋆) * w) * (y⇧^ω * bot ⊔ y⇧^⋆)" nitpick [expect=genuine,card=5] oops
*)

end

text ‹Theorem 50.2›

sublocale left_omega_algebra < comb0: left_conway_semiring where circ = "(λx . x⇧^⋆ * (x⇧^ω * bot ⊔ 1))"
  apply unfold_locales
  apply (smt sup_assoc sup_commute le_iff_sup mult_assoc mult_left_sub_dist_sup_left omega_unfold star.circ_loop_fixpoint star_mult_omega)
  using omega_bot_left_slide mult_assoc apply fastforce
  using omega_bot_add_1 mult_assoc by simp

class left_zero_omega_algebra = left_zero_kleene_algebra + left_omega_algebra
begin

lemma star_omega_absorb:
  "y⇧^⋆ * (y⇧^⋆ * x)⇧^⋆ * y⇧^ω = (y⇧^⋆ * x)⇧^⋆ * y⇧^ω"
proof -
  have "y⇧^⋆ * (y⇧^⋆ * x)⇧^⋆ * y⇧^ω = y⇧^⋆ * y⇧^⋆ * x * (y⇧^⋆ * x)⇧^⋆ * y⇧^ω ⊔ y⇧^⋆ * y⇧^ω"
    by (metis sup_commute mult_assoc mult_right_dist_sup star.circ_back_loop_fixpoint star.circ_plus_same)
  thus ?thesis
    by (metis mult_assoc star.circ_loop_fixpoint star.circ_transitive_equal star_mult_omega)
qed

lemma omega_circ_simulate_right_plus: 
  assumes "z * x ≤ y * (y⇧^ω * bot ⊔ y⇧^⋆) * z ⊔ w"
    shows "z * (x⇧^ω * bot ⊔ x⇧^⋆) ≤ (y⇧^ω * bot ⊔ y⇧^⋆) * (z ⊔ w * (x⇧^ω * bot ⊔ x⇧^⋆))"
proof -
  have 1: "z * x ≤ y⇧^ω * bot ⊔ y * y⇧^⋆ * z ⊔ w"
    by (metis assms mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup omega_unfold)
  hence "(y⇧^ω * bot ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * x⇧^ω * bot ⊔ y⇧^⋆ * w * x⇧^⋆) * x ≤ y⇧^ω * bot ⊔ y⇧^⋆ * (y⇧^ω * bot ⊔ y * y⇧^⋆ * z ⊔ w) ⊔ y⇧^⋆ * w * x⇧^ω * bot ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (smt sup_assoc sup_ge1 sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup star.circ_back_loop_fixpoint)
  also have "... = y⇧^ω * bot ⊔ y⇧^⋆ * y * y⇧^⋆ * z ⊔ y⇧^⋆ * w * x⇧^ω * bot ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (smt sup_assoc sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup star.circ_back_loop_fixpoint star_mult_omega)
  also have "... ≤ y⇧^ω * bot ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * x⇧^ω * bot ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (smt sup_commute sup_left_isotone mult_left_isotone star.circ_increasing star.circ_plus_same star.circ_transitive_equal)
  finally have "z ⊔ (y⇧^ω * bot ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * x⇧^ω * bot ⊔ y⇧^⋆ * w * x⇧^⋆) * x ≤ y⇧^ω * bot ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * x⇧^ω * bot ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (metis (no_types, lifting) le_supE le_supI star.circ_loop_fixpoint sup.cobounded1)
  hence 2: "z * x⇧^⋆ ≤ y⇧^ω * bot ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * x⇧^ω * bot ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (simp add: star_right_induct)
  have "z * x⇧^ω * bot ≤ (y⇧^ω * bot ⊔ y * y⇧^⋆ * z ⊔ w) * x⇧^ω * bot"
    using 1 by (smt sup_left_divisibility mult_assoc mult_right_sub_dist_sup_left omega_unfold)
  hence "z * x⇧^ω * bot ≤ y⇧^ω ⊔ y⇧^⋆ * (y⇧^ω * bot ⊔ w * x⇧^ω * bot)"
    by (smt sup_assoc sup_commute left_plus_omega mult_assoc mult_left_zero mult_right_dist_sup omega_induct star.left_plus_circ)
  thus "z * (x⇧^ω * bot ⊔ x⇧^⋆) ≤ (y⇧^ω * bot ⊔ y⇧^⋆) * (z ⊔ w * (x⇧^ω * bot ⊔ x⇧^⋆))"
    using 2 by (smt sup_assoc sup_commute le_iff_sup mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup omega_unfold omega_bot star_mult_omega zero_right_mult_decreasing)
qed

lemma omega_circ_simulate_left_plus:
  assumes "x * z ≤ z * (y⇧^ω * bot ⊔ y⇧^⋆) ⊔ w"
    shows "(x⇧^ω * bot ⊔ x⇧^⋆) * z ≤ (z ⊔ (x⇧^ω * bot ⊔ x⇧^⋆) * w) * (y⇧^ω * bot ⊔ y⇧^⋆)"
proof -
  have "x * (z * y⇧^ω * bot ⊔ z * y⇧^⋆ ⊔ x⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^⋆) = x * z * y⇧^ω * bot ⊔ x * z * y⇧^⋆ ⊔ x⇧^ω * bot ⊔ x * x⇧^⋆ * w * y⇧^ω * bot ⊔ x * x⇧^⋆ * w * y⇧^⋆"
    by (smt mult_assoc mult_left_dist_sup omega_unfold)
  also have "... ≤ x * z * y⇧^ω * bot ⊔ x * z * y⇧^⋆ ⊔ x⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (metis sup_mono sup_right_isotone mult_left_isotone star.left_plus_below_circ)
  also have "... ≤ (z * y⇧^ω * bot ⊔ z * y⇧^⋆ ⊔ w) * y⇧^ω * bot ⊔ (z * y⇧^ω * bot ⊔ z * y⇧^⋆ ⊔ w) * y⇧^⋆ ⊔ x⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (metis assms sup_left_isotone mult_assoc mult_left_dist_sup mult_left_isotone)
  also have "... = z * y⇧^ω * bot ⊔ z * y⇧^⋆ * y⇧^ω * bot ⊔ w * y⇧^ω * bot ⊔ z * y⇧^ω * bot ⊔ z * y⇧^⋆ * y⇧^⋆ ⊔ w * y⇧^⋆ ⊔ x⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (smt sup_assoc mult_assoc mult_left_zero mult_right_dist_sup)
  also have "... = z * y⇧^ω * bot ⊔ z * y⇧^⋆ ⊔ x⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (smt (verit, ccfv_threshold) sup_assoc sup_commute sup_idem mult_assoc mult_right_dist_sup star.circ_loop_fixpoint star.circ_transitive_equal star_mult_omega)
  finally have "x⇧^⋆ * z ≤ z * y⇧^ω * bot ⊔ z * y⇧^⋆ ⊔ x⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (smt (z3) le_supE sup_least sup_ge1 star.circ_back_loop_fixpoint star_left_induct)
  hence "(x⇧^ω * bot ⊔ x⇧^⋆) * z ≤ z * y⇧^ω * bot ⊔ z * y⇧^⋆ ⊔ x⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^ω * bot ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (smt (z3) sup.left_commute sup_commute sup_least sup_ge1 mult_assoc mult_left_zero mult_right_dist_sup)
  thus "(x⇧^ω * bot ⊔ x⇧^⋆) * z ≤ (z ⊔ (x⇧^ω * bot ⊔ x⇧^⋆) * w) * (y⇧^ω * bot ⊔ y⇧^⋆)"
    by (smt sup_assoc mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup)
qed

lemma omega_translate:
  "x⇧^⋆ * (x⇧^ω * bot ⊔ 1) = x⇧^ω * bot ⊔ x⇧^⋆"
  by (metis mult_assoc mult_left_dist_sup mult_1_right star_mult_omega)

lemma omega_circ_simulate_right:
  assumes "z * x ≤ y * z ⊔ w"
    shows "z * (x⇧^ω * bot ⊔ x⇧^⋆) ≤ (y⇧^ω * bot ⊔ y⇧^⋆) * (z ⊔ w * (x⇧^ω * bot ⊔ x⇧^⋆))"
proof -
  have "... ≤ y * (y⇧^ω * bot ⊔ y⇧^⋆) * z ⊔ w"
    using comb0.circ_mult_increasing mult_isotone sup_left_isotone omega_translate by auto
  thus "z * (x⇧^ω * bot ⊔ x⇧^⋆) ≤ (y⇧^ω * bot ⊔ y⇧^⋆) * (z ⊔ w * (x⇧^ω * bot ⊔ x⇧^⋆))"
    using assms order_trans omega_circ_simulate_right_plus by blast
qed

end

sublocale left_zero_omega_algebra < comb1: left_conway_semiring_1 where circ = "(λx . x⇧^⋆ * (x⇧^ω * bot ⊔ 1))"
  apply unfold_locales
  by (smt order.eq_iff mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup mult_1_right omega_slide star_slide)

sublocale left_zero_omega_algebra < comb0: itering where circ = "(λx . x⇧^⋆ * (x⇧^ω * bot ⊔ 1))"
  apply unfold_locales
  using comb1.circ_sup_9 apply blast
  using comb1.circ_mult_1 apply blast
  apply (metis omega_circ_simulate_right_plus omega_translate)
  using omega_circ_simulate_left_plus omega_translate by auto

text ‹Theorem 2.2›

sublocale left_zero_omega_algebra < comb2: itering where circ = "(λx . x⇧^ω * bot ⊔ x⇧^⋆)"
  apply unfold_locales
  using comb1.circ_sup_9 omega_translate apply force
  apply (metis comb1.circ_mult_1 omega_translate)
  using omega_circ_simulate_right_plus apply blast
  by (simp add: omega_circ_simulate_left_plus)

class omega_algebra = kleene_algebra + left_zero_omega_algebra

class left_omega_conway_semiring = left_omega_algebra + left_conway_semiring
begin

subclass left_kleene_conway_semiring ..

lemma circ_below_omega_star:
  "x⇧^∘ ≤ x⇧^ω ⊔ x⇧^⋆"
  by (metis circ_left_unfold mult_1_right omega_induct order_refl)

lemma omega_mult_circ:
  "x⇧^ω * x⇧^∘ = x⇧^ω"
  by (metis circ_star omega_mult_star_2)

lemma circ_mult_omega:
  "x⇧^∘ * x⇧^ω = x⇧^ω"
  by (metis order.antisym sup_right_divisibility circ_loop_fixpoint circ_plus_sub omega_simulation)

lemma circ_omega_greatest:
  "x⇧^∘⇧^ω = 1⇧^ω"
  by (metis circ_star star_omega_greatest)

lemma omega_circ:
  "x⇧^ω⇧^∘ = 1 ⊔ x⇧^ω"
  by (metis order.antisym circ_left_unfold mult_left_sub_dist_sup_left mult_1_right omega_sub_vector)

end

class bounded_left_omega_algebra = bounded_left_kleene_algebra + left_omega_algebra
begin

lemma omega_one:
  "1⇧^ω = top"
  by (simp add: order.antisym omega_one_greatest)

lemma star_omega_top:
  "x⇧^⋆⇧^ω = top"
  by (simp add: star_omega_greatest omega_one)

lemma omega_vector:
  "x⇧^ω * top = x⇧^ω"
  by (simp add: order.antisym omega_sub_vector top_right_mult_increasing)

lemma mult_top_omega:
  "(x * top)⇧^ω ≤ x * top"
  using mult_greatest_omega omega_one by auto

end

sublocale bounded_left_omega_algebra < comb0: bounded_left_conway_semiring where circ = "(λx . x⇧^⋆ * (x⇧^ω * bot ⊔ 1))" ..

class bounded_left_zero_omega_algebra = bounded_left_zero_kleene_algebra + left_zero_omega_algebra
begin

subclass bounded_left_omega_algebra ..

end

sublocale bounded_left_zero_omega_algebra < comb0: bounded_itering where circ = "(λx . x⇧^⋆ * (x⇧^ω * bot ⊔ 1))" ..

class bounded_omega_algebra = bounded_kleene_algebra + omega_algebra
begin

subclass bounded_left_zero_omega_algebra ..

end

class bounded_left_omega_conway_semiring = bounded_left_omega_algebra + left_omega_conway_semiring
begin

subclass left_kleene_conway_semiring ..

subclass bounded_left_conway_semiring ..

lemma circ_omega:
  "x⇧^∘⇧^ω = top"
  by (simp add: circ_omega_greatest omega_one)

end

class top_left_omega_algebra = bounded_left_omega_algebra +
  assumes top_left_bot: "top * x = top"
begin

lemma omega_translate_3:
  "x⇧^⋆ * (x⇧^ω * bot ⊔ 1) = x⇧^⋆ * (x⇧^ω ⊔ 1)"
  by (metis omega_one omega_vector_greatest top_left_bot mult_assoc)

end

text ‹Theorem 50.2›

sublocale top_left_omega_algebra < comb4: left_conway_semiring where circ = "(λx . x⇧^⋆ * (x⇧^ω ⊔ 1))"
  apply unfold_locales
  using comb0.circ_left_unfold omega_translate_3 apply force
  using omega_bot_left_slide omega_translate_3 mult_assoc apply force
  using comb0.circ_sup_1 omega_translate_3 by auto

class top_left_bot_omega_algebra = bounded_left_zero_omega_algebra +
  assumes top_left_bot: "top * x = top"
begin

lemma omega_translate_2:
  "x⇧^ω * bot ⊔ x⇧^⋆ = x⇧^ω ⊔ x⇧^⋆"
  by (metis mult_assoc omega_mult_star_2 star.circ_top top_left_bot)

end

text ‹Theorem 2.3›

sublocale top_left_bot_omega_algebra < comb3: itering where circ = "(λx . x⇧^ω ⊔ x⇧^⋆)"
  apply unfold_locales
  using comb2.circ_slide_1 comb2.circ_sup_1 omega_translate_2 apply force
  apply (metis comb2.circ_mult_1 omega_translate_2)
  using omega_circ_simulate_right_plus omega_translate_2 apply force
  using omega_circ_simulate_left_plus omega_translate_2 by auto

class Omega =
  fixes Omega :: "'a ⇒ 'a" ("_⇧^Ω" [100] 100)

end

Theory Capped_Omega_Algebras

(* Title:      Capped Omega Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Capped Omega Algebras›

theory Capped_Omega_Algebras

imports Omega_Algebras

begin

class capped_omega =
  fixes capped_omega :: "'a ⇒ 'a ⇒ 'a" ("_⇧^ω⇩_" [100,100] 100)

class capped_omega_algebra = bounded_left_zero_kleene_algebra + bounded_distrib_lattice + capped_omega +
  assumes capped_omega_unfold: "y⇧^ω⇩v = y * y⇧^ω⇩v ⊓ v"
  assumes capped_omega_induct: "x ≤ (y * x ⊔ z) ⊓ v ⟶ x ≤ y⇧^ω⇩v ⊔ y⇧^⋆ * z"

text ‹AACP Theorem 6.1›

notation
  top ("⊤")

sublocale capped_omega_algebra < capped: bounded_left_zero_omega_algebra where omega = "(λy . y⇧^ω⇩⊤)"
  apply unfold_locales
  apply (metis capped_omega_unfold inf_top_right)
  by (simp add: capped_omega_induct sup_commute)

context capped_omega_algebra
begin

text ‹AACP Theorem 6.2›

lemma capped_omega_below_omega:
  "y⇧^ω⇩v ≤ y⇧^ω⇩⊤"
  using capped.omega_induct_mult capped_omega_unfold order.eq_iff by force

text ‹AACP Theorem 6.3›

lemma capped_omega_below:
  "y⇧^ω⇩v ≤ v"
  using capped_omega_unfold order.eq_iff by force

text ‹AACP Theorem 6.4›

lemma capped_omega_one:
  "1⇧^ω⇩v = v"
proof -
  have "v ≤ (1 * v ⊔ bot) ⊓ v"
    by simp
  hence "v ≤ 1⇧^ω⇩v ⊔ 1⇧^⋆ * bot"
    by (simp add: capped_omega_induct)
  also have "... = 1⇧^ω⇩v"
    by (simp add: star_one)
  finally show ?thesis
    by (simp add: capped_omega_below order.antisym)
qed

text ‹AACP Theorem 6.5›

lemma capped_omega_zero:
  "bot⇧^ω⇩v = bot"
  by (metis capped_omega_below_omega bot_unique capped.omega_bot)

lemma star_below_cap:
  "y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ y⇧^⋆ * z ≤ v"
  by (metis le_sup_iff order.trans mult_left_isotone star_left_induct)

lemma capped_fix:
  assumes "y ≤ u"
      and "z ≤ v"
      and "u * v ≤ v"
    shows "(y * (y⇧^ω⇩v ⊔ y⇧^⋆ * z) ⊔ z) ⊓ v = y⇧^ω⇩v ⊔ y⇧^⋆ * z"
proof -
  have "(y * (y⇧^ω⇩v ⊔ y⇧^⋆ * z) ⊔ z) ⊓ v = (y * y⇧^ω⇩v ⊔ y⇧^⋆ * z) ⊓ v"
    by (simp add: mult_left_dist_sup star.circ_loop_fixpoint sup_assoc)
  also have "... = (y * y⇧^ω⇩v ⊓ v) ⊔ (y⇧^⋆ * z ⊓ v)"
    by (simp add: inf_sup_distrib2)
  also have "... = y⇧^ω⇩v ⊔ y⇧^⋆ * z"
    using assms capped_omega_unfold le_iff_inf star_below_cap by auto
  finally show ?thesis
    .
qed

lemma capped_fixpoint:
  "y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ is_fixpoint (λx . (y * x ⊔ z) ⊓ v) (y⇧^ω⇩v ⊔ y⇧^⋆ * z)"
  by (simp add: capped_fix is_fixpoint_def)

lemma capped_greatest_fixpoint:
  "y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ is_greatest_fixpoint (λx . (y * x ⊔ z) ⊓ v) (y⇧^ω⇩v ⊔ y⇧^⋆ * z)"
  by (smt capped_fix order_refl capped_omega_induct is_greatest_fixpoint_def)

lemma capped_postfixpoint:
  "y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ is_postfixpoint (λx . (y * x ⊔ z) ⊓ v) (y⇧^ω⇩v ⊔ y⇧^⋆ * z)"
  using capped_fix inf.eq_refl is_postfixpoint_def by auto

lemma capped_greatest_postfixpoint:
  "y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ is_greatest_postfixpoint (λx . (y * x ⊔ z) ⊓ v) (y⇧^ω⇩v ⊔ y⇧^⋆ * z)"
  by (smt capped_fix order_refl capped_omega_induct is_greatest_postfixpoint_def)

text ‹AACP Theorem 6.6›

lemma capped_nu:
  "y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ ν(λx . (y * x ⊔ z) ⊓ v) = y⇧^ω⇩v ⊔ y⇧^⋆ * z"
  by (metis capped_greatest_fixpoint greatest_fixpoint_same)

lemma capped_pnu:
  "y ≤ u ⟹ z ≤ v ⟹ u * v ≤ v ⟹ pν(λx . (y * x ⊔ z) ⊓ v) = y⇧^ω⇩v ⊔ y⇧^⋆ * z"
  by (metis capped_greatest_postfixpoint greatest_postfixpoint_same)

text ‹AACP Theorem 6.7›

lemma unfold_capped_omega:
  "y ≤ u ⟹ u * v ≤ v ⟹ y * y⇧^ω⇩v = y⇧^ω⇩v"
  by (smt (verit, ccfv_SIG) capped_omega_below capped_omega_unfold inf.order_lesseq_imp le_iff_inf mult_isotone)

text ‹AACP Theorem 6.8›

lemma star_mult_capped_omega:
  assumes "y ≤ u"
      and "u * v ≤ v"
    shows "y⇧^⋆ * y⇧^ω⇩v = y⇧^ω⇩v"
proof -
  have "y * y⇧^ω⇩v = y⇧^ω⇩v"
    using assms unfold_capped_omega by auto
  hence "y⇧^⋆ * y⇧^ω⇩v ≤ y⇧^ω⇩v"
    by (simp add: star_left_induct_mult)
  thus ?thesis
    by (metis sup_ge2 order.antisym star.circ_loop_fixpoint)
qed

text ‹AACP Theorem 6.9›

lemma star_zero_below_capped_omega_zero:
  assumes "y ≤ u"
      and "u * v ≤ v"
    shows "y⇧^⋆ * bot ≤ y⇧^ω⇩v * bot"
proof -
  have "y * y⇧^ω⇩v ≤ v"
    using assms capped_omega_below unfold_capped_omega by auto
  hence "y * y⇧^ω⇩v = y⇧^ω⇩v"
    using assms unfold_capped_omega by auto
  thus ?thesis
    by (metis bot_least eq_refl mult_assoc star_below_cap)
qed

lemma star_zero_below_capped_omega:
  "y ≤ u ⟹ u * v ≤ v ⟹ y⇧^⋆ * bot ≤ y⇧^ω⇩v"
  by (simp add: star_loop_least_fixpoint unfold_capped_omega)

lemma capped_omega_induct_meet_zero:
  "x ≤ y * x ⊓ v ⟹ x ≤ y⇧^ω⇩v ⊔ y⇧^⋆ * bot"
  by (simp add: capped_omega_induct)

text ‹AACP Theorem 6.10›

lemma capped_omega_induct_meet:
  "y ≤ u ⟹ u * v ≤ v ⟹ x ≤ y * x ⊓ v ⟹ x ≤ y⇧^ω⇩v"
  by (metis capped_omega_induct_meet_zero sup_commute le_iff_sup star_zero_below_capped_omega)

lemma capped_omega_induct_equal:
  "x = (y * x ⊔ z) ⊓ v ⟹ x ≤ y⇧^ω⇩v ⊔ y⇧^⋆ * z"
  using capped_omega_induct inf.le_iff_sup by auto

text ‹AACP Theorem 6.11›

lemma capped_meet_nu:
  assumes "y ≤ u"
      and "u * v ≤ v"
    shows "ν(λx . y * x ⊓ v) = y⇧^ω⇩v"
proof -
  have "y⇧^ω⇩v ⊔ y⇧^⋆ * bot = y⇧^ω⇩v"
    by (smt assms star_zero_below_capped_omega le_iff_sup sup_commute)
  hence "ν(λx . (y * x ⊔ bot) ⊓ v) = y⇧^ω⇩v"
    by (metis assms capped_nu bot_least)
  thus ?thesis
    by simp
qed

lemma capped_meet_pnu:
  assumes "y ≤ u"
      and "u * v ≤ v"
    shows "pν(λx . y * x ⊓ v) = y⇧^ω⇩v"
proof -
  have "y⇧^ω⇩v ⊔ y⇧^⋆ * bot = y⇧^ω⇩v"
    by (smt assms star_zero_below_capped_omega le_iff_sup sup_commute)
  hence "pν(λx . (y * x ⊔ bot) ⊓ v) = y⇧^ω⇩v"
    by (metis assms capped_pnu bot_least)
  thus ?thesis
    by simp
qed

text ‹AACP Theorem 6.12›

lemma capped_omega_isotone:
  "y ≤ u ⟹ u * v ≤ v ⟹ t ≤ y ⟹ t⇧^ω⇩v ≤ y⇧^ω⇩v"
  by (metis capped_omega_induct_meet capped_omega_unfold le_iff_sup inf.sup_left_isotone mult_right_sub_dist_sup_left)

text ‹AACP Theorem 6.13›

lemma capped_omega_simulation:
  assumes "y ≤ u"
      and "s ≤ u"
      and "u * v ≤ v"
      and "s * t ≤ y * s"
    shows "s * t⇧^ω⇩v ≤ y⇧^ω⇩v"
proof -
  have "s * t⇧^ω⇩v ≤ s * t * t⇧^ω⇩v ⊓ s * v"
    by (metis capped_omega_below capped_omega_unfold inf.boundedI inf.cobounded1 mult_right_isotone mult_assoc)
  also have "... ≤ s * t * t⇧^ω⇩v ⊓ v"
    using assms(2,3) inf.order_lesseq_imp inf.sup_right_isotone mult_left_isotone by blast
  also have "... ≤ y * s * t⇧^ω⇩v ⊓ v"
    using assms(4) inf.sup_left_isotone mult_left_isotone by auto
  finally show ?thesis
    using assms(1,3) capped_omega_induct_meet mult_assoc by auto
qed

lemma capped_omega_slide_sub:
  assumes "s ≤ u"
      and "y ≤ u"
      and "u * u ≤ u"
      and "u * v ≤ v"
    shows "s * (y * s)⇧^ω⇩v ≤ (s * y)⇧^ω⇩v"
proof -
  have "s * y ≤ u"
    by (meson assms(1-3) mult_isotone order_trans)
  thus ?thesis
    using assms(1,4) capped_omega_simulation mult_assoc by auto 
qed

text ‹AACP Theorem 6.14›

lemma capped_omega_slide:
  "s ≤ u ⟹ y ≤ u ⟹ u * u ≤ u ⟹ u * v ≤ v ⟹ s * (y * s)⇧^ω⇩v = (s * y)⇧^ω⇩v"
  by (smt (verit) order.antisym mult_assoc mult_right_isotone capped_omega_unfold capped_omega_slide_sub inf.sup_ge1 order_trans)

lemma capped_omega_sub_dist:
  "s ≤ u ⟹ y ≤ u ⟹ u * v ≤ v ⟹ s⇧^ω⇩v ≤ (s ⊔ y)⇧^ω⇩v"
  by (simp add: capped_omega_isotone)

text ‹AACP Theorem 6.15›

lemma capped_omega_simulation_2:
  assumes "s ≤ u"
      and "y ≤ u"
      and "u * u ≤ u"
      and "u * v ≤ v"
      and "y * s ≤ s * y"
    shows "(s * y)⇧^ω⇩v ≤ s⇧^ω⇩v"
proof -
  have 1: "s * y ≤ u"
    using assms(1-3) inf.order_lesseq_imp mult_isotone by blast
  have 2: "s * (s * y)⇧^ω⇩v ≤ v"
    by (meson assms(1,4) capped_omega_below order.trans mult_isotone)
  have "(s * y)⇧^ω⇩v = s * (y * s)⇧^ω⇩v"
    using assms(1-4) capped_omega_slide by auto
  also have "... ≤ s * (s * y)⇧^ω⇩v"
    using 1 assms(4,5) capped_omega_isotone mult_right_isotone by blast
  also have "... = s * (s * y)⇧^ω⇩v ⊓ v"
    using 2 inf.order_iff by auto
  finally show ?thesis
    using assms(1,4) capped_omega_induct_meet by blast
qed

text ‹AACP Theorem 6.16›

lemma left_plus_capped_omega:
  assumes "y ≤ u"
      and "u * u ≤ u"
      and "u * v ≤ v"
    shows "(y * y⇧^⋆)⇧^ω⇩v = y⇧^ω⇩v"
proof -
  have 1: "y * y⇧^⋆ ≤ u"
    by (metis assms(1,2) star_plus star_below_cap)
  hence "y * y⇧^⋆ * (y * y⇧^⋆)⇧^ω⇩v ≤ v"
    using assms(3) capped_omega_below unfold_capped_omega by auto
  hence "y * y⇧^⋆ * (y * y⇧^⋆)⇧^ω⇩v = (y * y⇧^⋆)⇧^ω⇩v"
    using 1 assms(3) unfold_capped_omega by blast
  hence "(y * y⇧^⋆)⇧^ω⇩v ≤ y⇧^ω⇩v"
    using 1 by (smt assms(1,3) capped_omega_simulation mult_assoc mult_semi_associative star.circ_transitive_equal star_simulation_right_equal)
  thus ?thesis
    using 1 by (meson assms(3) capped_omega_isotone order.antisym star.circ_mult_increasing)
qed

text ‹AACP Theorem 6.17›

lemma capped_omega_sub_vector:
  assumes "z ≤ v"
      and "y ≤ u"
      and "u * v ≤ v"
    shows "y⇧^ω⇩u * z ≤ y⇧^ω⇩v"
proof -
  have "y⇧^ω⇩u * z ≤ y * y⇧^ω⇩u * z ⊓ u * z"
    by (metis capped_omega_below capped_omega_unfold eq_refl inf.boundedI inf.cobounded1 mult_isotone)
  also have "... ≤ y * y⇧^ω⇩u * z ⊓ v"
    by (metis assms(1,3) inf.sup_left_isotone inf_commute mult_right_isotone order_trans)
  finally show ?thesis
    using assms(2,3) capped_omega_induct_meet mult_assoc by auto
qed

text ‹AACP Theorem 6.18›

lemma capped_omega_omega:
  "y ≤ u ⟹ u * v ≤ v ⟹ (y⇧^ω⇩u)⇧^ω⇩v ≤ y⇧^ω⇩v"
  by (metis capped_omega_below capped_omega_sub_vector unfold_capped_omega)

end

end

Theory General_Refinement_Algebras

(* Title:      General Refinement Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹General Refinement Algebras›

theory General_Refinement_Algebras

imports Omega_Algebras

begin

class general_refinement_algebra = left_kleene_algebra + Omega +
  assumes Omega_unfold: "y⇧^Ω ≤ 1 ⊔ y * y⇧^Ω"
  assumes Omega_induct: "x ≤ z ⊔ y * x ⟶ x ≤ y⇧^Ω * z"
begin

lemma Omega_unfold_equal:
  "y⇧^Ω = 1 ⊔ y * y⇧^Ω"
  by (smt Omega_induct Omega_unfold sup_right_isotone order.antisym mult_right_isotone mult_1_right)

lemma Omega_sup_1:
  "(x ⊔ y)⇧^Ω = x⇧^Ω * (y * x⇧^Ω)⇧^Ω"
  apply (rule order.antisym)
  apply (smt Omega_induct Omega_unfold_equal sup_assoc sup_commute sup_right_isotone mult_assoc mult_right_dist_sup mult_right_isotone mult_1_right order_refl)
  by (smt Omega_induct Omega_unfold_equal sup_assoc sup_commute mult_assoc mult_left_one mult_right_dist_sup mult_1_right order_refl)

lemma Omega_left_slide:
  "(x * y)⇧^Ω * x ≤ x * (y * x)⇧^Ω"
proof -
  have "1 ⊔ y * (x * y)⇧^Ω * x ≤ 1 ⊔ y * x * (1 ⊔ (y * (x * y)⇧^Ω) * x)"
    by (smt Omega_unfold_equal sup_right_isotone mult_assoc mult_left_one mult_left_sub_dist_sup mult_right_dist_sup mult_right_isotone mult_1_right)
  thus ?thesis
    by (smt Omega_induct Omega_unfold_equal le_sup_iff mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone mult_1_right)
qed

end

text ‹Theorem 50.3›

sublocale general_refinement_algebra < Omega: left_conway_semiring where circ = Omega
  apply unfold_locales
  using Omega_unfold_equal apply simp
  apply (simp add: Omega_left_slide)
  by (simp add: Omega_sup_1)

context general_refinement_algebra
begin

lemma star_below_Omega:
  "x⇧^⋆ ≤ x⇧^Ω"
  by (metis Omega_induct mult_1_right order_refl star.circ_left_unfold)

lemma star_mult_Omega:
  "x⇧^Ω = x⇧^⋆ * x⇧^Ω"
  by (metis Omega.left_plus_below_circ sup_commute sup_ge1 order.eq_iff star.circ_loop_fixpoint star_left_induct_mult_iff)

lemma Omega_one_greatest:
  "x ≤ 1⇧^Ω"
  by (metis Omega_induct sup_bot_left mult_left_one order_refl order_trans zero_right_mult_decreasing)

lemma greatest_left_zero:
  "1⇧^Ω * x = 1⇧^Ω"
  by (simp add: Omega_one_greatest Omega_induct order.antisym)

(*
lemma circ_right_unfold: "1 ⊔ x⇧^Ω * x = x⇧^Ω" nitpick [expect=genuine,card=8] oops
lemma circ_slide: "(x * y)⇧^Ω * x = x * (y * x)⇧^Ω" nitpick [expect=genuine,card=6] oops
lemma circ_simulate: "z * x ≤ y * z ⟹ z * x⇧^Ω ≤ y⇧^Ω * z" nitpick [expect=genuine,card=6] oops
lemma circ_simulate_right: "z * x ≤ y * z ⊔ w ⟹ z * x⇧^Ω ≤ y⇧^Ω * (z ⊔ w * x⇧^Ω)" nitpick [expect=genuine,card=6] oops
lemma circ_simulate_right_1: "z * x ≤ y * z ⟹ z * x⇧^Ω ≤ y⇧^Ω * z" nitpick [expect=genuine,card=6] oops
lemma circ_simulate_right_plus: "z * x ≤ y * y⇧^Ω * z ⊔ w ⟹ z * x⇧^Ω ≤ y⇧^Ω * (z ⊔ w * x⇧^Ω)" nitpick [expect=genuine,card=6] oops
lemma circ_simulate_right_plus_1: "z * x ≤ y * y⇧^Ω * z ⟹ z * x⇧^Ω ≤ y⇧^Ω * z" nitpick [expect=genuine,card=6] oops
lemma circ_simulate_left_1: "x * z ≤ z * y ⟹ x⇧^Ω * z ≤ z * y⇧^Ω ⊔ x⇧^Ω * bot" oops (* holds in LKA, counterexample exists in GRA *)
lemma circ_simulate_left_plus_1: "x * z ≤ z * y⇧^Ω ⟹ x⇧^Ω * z ≤ z * y⇧^Ω ⊔ x⇧^Ω * bot" oops (* holds in LKA, counterexample exists in GRA *)
lemma circ_simulate_absorb: "y * x ≤ x ⟹ y⇧^Ω * x ≤ x ⊔ y⇧^Ω * bot" nitpick [expect=genuine,card=8] oops (* holds in LKA, counterexample exists in GRA *)
*)

end

class bounded_general_refinement_algebra = general_refinement_algebra + bounded_left_kleene_algebra
begin

lemma Omega_one:
  "1⇧^Ω = top"
  by (simp add: Omega_one_greatest order.antisym)

lemma top_left_zero:
  "top * x = top"
  using Omega_one greatest_left_zero by blast

end

sublocale bounded_general_refinement_algebra < Omega: bounded_left_conway_semiring where circ = Omega ..

class left_demonic_refinement_algebra = general_refinement_algebra +
  assumes Omega_isolate: "y⇧^Ω ≤ y⇧^Ω * bot ⊔ y⇧^⋆"
begin

lemma Omega_isolate_equal:
  "y⇧^Ω = y⇧^Ω * bot ⊔ y⇧^⋆"
  using Omega_isolate order.antisym le_sup_iff star_below_Omega zero_right_mult_decreasing by auto

(*
lemma Omega_sum_unfold_1: "(x ⊔ y)⇧^Ω = y⇧^Ω ⊔ y⇧^⋆ * x * (x ⊔ y)⇧^Ω" oops
lemma Omega_sup_3: "(x ⊔ y)⇧^Ω = (x⇧^⋆ * y)⇧^Ω * x⇧^Ω" oops
*)

end

class bounded_left_demonic_refinement_algebra = left_demonic_refinement_algebra + bounded_left_kleene_algebra
begin

(*
lemma Omega_mult: "(x * y)⇧^Ω = 1 ⊔ x * (y * x)⇧^Ω * y" oops
lemma Omega_sup: "(x ⊔ y)⇧^Ω = (x⇧^Ω * y)⇧^Ω * x⇧^Ω" oops
lemma Omega_simulate: "z * x ≤ y * z ⟹ z * x⇧^Ω ≤ y⇧^Ω * z" nitpick [expect=genuine,card=6] oops
lemma Omega_separate_2: "y * x ≤ x * (x ⊔ y) ⟹ (x ⊔ y)⇧^Ω = x⇧^Ω * y⇧^Ω" oops
lemma Omega_circ_simulate_right_plus: "z * x ≤ y * y⇧^Ω * z ⊔ w ⟹ z * x⇧^Ω ≤ y⇧^Ω * (z ⊔ w * x⇧^Ω)" nitpick [expect=genuine,card=6] oops
lemma Omega_circ_simulate_left_plus: "x * z ≤ z * y⇧^Ω ⊔ w ⟹ x⇧^Ω * z ≤ (z ⊔ x⇧^Ω * w) * y⇧^Ω" oops
*)

end

sublocale bounded_left_demonic_refinement_algebra < Omega: bounded_left_conway_semiring where circ = Omega ..

class demonic_refinement_algebra = left_zero_kleene_algebra + left_demonic_refinement_algebra
begin

lemma Omega_mult:
  "(x * y)⇧^Ω = 1 ⊔ x * (y * x)⇧^Ω * y"
  by (smt (verit, del_insts) Omega.circ_left_slide Omega_induct Omega_unfold_equal order.eq_iff mult_assoc mult_left_dist_sup mult_1_right)

lemma Omega_sup:
  "(x ⊔ y)⇧^Ω = (x⇧^Ω * y)⇧^Ω * x⇧^Ω"
  by (smt Omega_sup_1 Omega_mult mult_assoc mult_left_dist_sup mult_left_one mult_right_dist_sup mult_1_right)

lemma Omega_simulate:
  "z * x ≤ y * z ⟹ z * x⇧^Ω ≤ y⇧^Ω * z"
  by (smt Omega_induct Omega_unfold_equal sup_right_isotone mult_assoc mult_left_dist_sup mult_left_isotone mult_1_right)

end

text ‹Theorem 2.4›

sublocale demonic_refinement_algebra < Omega1: itering_1 where circ = Omega
  apply unfold_locales
  apply (simp add: Omega_simulate mult_assoc)
  by (simp add: Omega_simulate)

sublocale demonic_refinement_algebra < Omega1: left_zero_conway_semiring_1 where circ = Omega ..

context demonic_refinement_algebra
begin

lemma Omega_sum_unfold_1:
  "(x ⊔ y)⇧^Ω = y⇧^Ω ⊔ y⇧^⋆ * x * (x ⊔ y)⇧^Ω"
  by (smt Omega1.circ_sup_9 Omega.circ_loop_fixpoint Omega_isolate_equal sup_assoc sup_commute mult_assoc mult_left_zero mult_right_dist_sup)

lemma Omega_sup_3:
  "(x ⊔ y)⇧^Ω = (x⇧^⋆ * y)⇧^Ω * x⇧^Ω"
  apply (rule order.antisym)
  apply (metis Omega_sum_unfold_1 Omega_induct eq_refl sup_commute)
  by (simp add: Omega.circ_isotone Omega_sup mult_left_isotone star_below_Omega)

lemma Omega_separate_2:
  "y * x ≤ x * (x ⊔ y) ⟹ (x ⊔ y)⇧^Ω = x⇧^Ω * y⇧^Ω"
  apply (rule order.antisym)
  apply (smt (verit, del_insts) Omega_induct Omega_sum_unfold_1 sup_right_isotone mult_assoc mult_left_isotone star_mult_Omega star_simulation_left)
  by (simp add: Omega.circ_sub_dist_3)

lemma Omega_circ_simulate_right_plus:
  assumes "z * x ≤ y * y⇧^Ω * z ⊔ w"
    shows "z * x⇧^Ω ≤ y⇧^Ω * (z ⊔ w * x⇧^Ω)"
proof -
  have "z * x⇧^Ω = z ⊔ z * x * x⇧^Ω"
    using Omega1.circ_back_loop_fixpoint Omega1.circ_plus_same sup_commute mult_assoc by auto
  also have "... ≤ y * y⇧^Ω * z * x⇧^Ω ⊔ z ⊔ w * x⇧^Ω"
    by (smt assms sup_assoc sup_commute sup_right_isotone le_iff_sup mult_right_dist_sup)
  finally have "z * x⇧^Ω ≤ (y * y⇧^Ω)⇧^Ω * (z ⊔ w * x⇧^Ω)"
    by (smt Omega_induct sup_assoc sup_commute mult_assoc)
  thus ?thesis
    by (simp add: Omega.left_plus_circ)
qed

lemma Omega_circ_simulate_left_plus:
  assumes "x * z ≤ z * y⇧^Ω ⊔ w"
    shows "x⇧^Ω * z ≤ (z ⊔ x⇧^Ω * w) * y⇧^Ω"
proof -
  have "x * ((z ⊔ x⇧^Ω * w) * y⇧^Ω) ≤ (z * y⇧^Ω ⊔ w ⊔ x * x⇧^Ω * w) * y⇧^Ω"
    by (smt assms mult_assoc mult_left_dist_sup sup_left_isotone mult_left_isotone)
  also have "... ≤ z * y⇧^Ω * y⇧^Ω ⊔ w * y⇧^Ω ⊔ x⇧^Ω * w * y⇧^Ω"
    by (smt Omega.left_plus_below_circ sup_right_isotone mult_left_isotone mult_right_dist_sup)
  finally have 1: "x * ((z ⊔ x⇧^Ω * w) * y⇧^Ω) ≤ (z ⊔ x⇧^Ω * w) * y⇧^Ω"
    by (metis Omega.circ_transitive_equal mult_assoc Omega.circ_reflexive sup_assoc le_iff_sup mult_left_one mult_right_dist_sup)
  have "x⇧^Ω * z  = x⇧^Ω * bot ⊔ x⇧^⋆ * z"
    by (metis Omega_isolate_equal mult_assoc mult_left_zero mult_right_dist_sup)
  also have "... ≤ x⇧^Ω * w * y⇧^Ω ⊔ x⇧^⋆ * (z ⊔ x⇧^Ω * w) * y⇧^Ω"
    by (metis Omega1.circ_back_loop_fixpoint bot_least idempotent_bot_closed le_supI2 mult_isotone mult_left_sub_dist_sup_left semiring.add_mono zero_right_mult_decreasing mult_assoc)
  also have "... ≤ (z ⊔ x⇧^Ω * w) * y⇧^Ω"
    using 1 by (metis le_supI mult_right_sub_dist_sup_right star_left_induct_mult mult_assoc)
  finally show ?thesis
    .
qed

lemma Omega_circ_simulate_right:
  assumes "z * x ≤ y * z ⊔ w"
    shows "z * x⇧^Ω ≤ y⇧^Ω * (z ⊔ w * x⇧^Ω)"
proof -
  have "y * z ⊔ w ≤ y * y⇧^Ω * z ⊔ w"
    using Omega.circ_mult_increasing mult_left_isotone sup_left_isotone by auto
  thus ?thesis
    using Omega_circ_simulate_right_plus assms order.trans by blast
qed

end

sublocale demonic_refinement_algebra < Omega: itering where circ = Omega
  apply unfold_locales
  apply (simp add: Omega_sup)
  using Omega_mult apply blast
  apply (simp add: Omega_circ_simulate_right_plus)
  using Omega_circ_simulate_left_plus by auto

class bounded_demonic_refinement_algebra = demonic_refinement_algebra + bounded_left_zero_kleene_algebra
begin

lemma Omega_one:
  "1⇧^Ω = top"
  by (simp add: Omega_one_greatest order.antisym)

lemma top_left_zero:
  "top * x = top"
  using Omega_one greatest_left_zero by auto

end

sublocale bounded_demonic_refinement_algebra < Omega: bounded_itering where circ = Omega ..

class general_refinement_algebra_omega = left_omega_algebra + Omega +
  assumes omega_left_zero: "x⇧^ω ≤ x⇧^ω * y"
  assumes Omega_def: "x⇧^Ω = x⇧^ω ⊔ x⇧^⋆"
begin

lemma omega_left_zero_equal:
  "x⇧^ω * y = x⇧^ω"
  by (simp add: order.antisym omega_left_zero omega_sub_vector)

subclass left_demonic_refinement_algebra
  apply unfold_locales
  apply (metis Omega_def sup_commute eq_refl mult_1_right omega_loop_fixpoint)
  apply (metis Omega_def mult_right_dist_sup omega_induct omega_left_zero_equal)
  by (metis Omega_def mult_right_sub_dist_sup_right sup_commute sup_right_isotone omega_left_zero_equal)

end

class left_demonic_refinement_algebra_omega = bounded_left_omega_algebra + Omega +
  assumes top_left_zero: "top * x = top"
  assumes Omega_def: "x⇧^Ω = x⇧^ω ⊔ x⇧^⋆"
begin

subclass general_refinement_algebra_omega
  apply unfold_locales
  apply (metis mult_assoc omega_vector order_refl top_left_zero)
  by (rule Omega_def)

end

class demonic_refinement_algebra_omega = left_demonic_refinement_algebra_omega + bounded_left_zero_omega_algebra
begin

lemma Omega_mult:
  "(x * y)⇧^Ω = 1 ⊔ x * (y * x)⇧^Ω * y"
  by (metis Omega_def comb1.circ_mult_1 omega_left_zero_equal omega_translate)

lemma Omega_sup:
  "(x ⊔ y)⇧^Ω = (x⇧^Ω * y)⇧^Ω * x⇧^Ω"
proof -
  have "(x⇧^Ω * y)⇧^Ω * x⇧^Ω = (x⇧^⋆ * y)⇧^⋆ * x⇧^ω ⊔ (x⇧^⋆ * y)⇧^ω ⊔ (x⇧^⋆ * y)⇧^⋆ * x⇧^ω⇧^⋆ * x⇧^Ω"
    by (smt sup_commute Omega_def mult_assoc mult_right_dist_sup mult_bot_add_omega omega_left_zero_equal star.circ_sup_1)
  thus ?thesis
    using Omega_def Omega_sup_1 comb2.circ_slide_1 omega_left_zero_equal by auto
qed

lemma Omega_simulate:
  "z * x ≤ y * z ⟹ z * x⇧^Ω ≤ y⇧^Ω * z"
  using Omega_def comb2.circ_simulate omega_left_zero_equal by auto

subclass demonic_refinement_algebra ..

end

(*
text hold in GRA and LKA
lemma circ_circ_mult: "1⇧^Ω * x⇧^Ω = x⇧^Ω⇧^Ω" oops
lemma sub_mult_one_circ: "x * 1⇧^Ω ≤ 1⇧^Ω * x" oops
lemma circ_circ_mult_1: "x⇧^Ω * 1⇧^Ω = x⇧^Ω⇧^Ω" oops
lemma "y * x ≤ x ⟹ y⇧^∘ * x ≤ 1⇧^∘ * x" oops

text unknown
lemma circ_simulate_2: "y * x⇧^Ω ≤ x⇧^Ω * y⇧^Ω ⟷ y⇧^Ω * x⇧^Ω ≤ x⇧^Ω * y⇧^Ω" oops (* holds in LKA *)
lemma circ_simulate_3: "y * x⇧^Ω ≤ x⇧^Ω ⟹ y⇧^Ω * x⇧^Ω ≤ x⇧^Ω * y⇧^Ω" oops (* holds in LKA *)
lemma circ_separate_mult_1: "y * x ≤ x * y ⟹ (x * y)⇧^Ω ≤ x⇧^Ω * y⇧^Ω" oops
lemma "x⇧^∘ = (x * x)⇧^∘ * (x ⊔ 1)" oops
lemma "y⇧^∘ * x⇧^∘ ≤ x⇧^∘ * y⇧^∘ ⟹ (x ⊔ y)⇧^∘ = x⇧^∘ * y⇧^∘" oops
lemma "y * x ≤ (1 ⊔ x) * y⇧^∘ ⟹ (x ⊔ y)⇧^∘ = x⇧^∘ * y⇧^∘" oops
*)

end

Theory Lattice_Ordered_Semirings

(* Title:      Lattice-Ordered Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Lattice-Ordered Semirings›

theory Lattice_Ordered_Semirings

imports Stone_Relation_Algebras.Semirings

begin

text ‹Many results in this theory are taken from a joint paper with Rudolf Berghammer.›

text ‹M0-algebra›

class lattice_ordered_pre_left_semiring = pre_left_semiring + bounded_distrib_lattice
begin

subclass bounded_pre_left_semiring
  apply unfold_locales
  by simp

lemma top_mult_right_one:
  "x * top = x * top * 1"
  by (metis order.antisym mult_sub_right_one mult_sup_associative_one surjective_one_closed)

lemma mult_left_sub_dist_inf_left:
  "x * (y ⊓ z) ≤ x * y"
  by (simp add: mult_right_isotone)

lemma mult_left_sub_dist_inf_right:
  "x * (y ⊓ z) ≤ x * z"
  by (simp add: mult_right_isotone)

lemma mult_right_sub_dist_inf_left:
  "(x ⊓ y) * z ≤ x * z"
  by (simp add: mult_left_isotone)

lemma mult_right_sub_dist_inf_right:
  "(x ⊓ y) * z ≤ y * z"
  by (simp add: mult_left_isotone)

lemma mult_right_sub_dist_inf:
  "(x ⊓ y) * z ≤ x * z ⊓ y * z"
  by (simp add: mult_right_sub_dist_inf_left mult_right_sub_dist_inf_right)

text ‹Figure 1: fundamental properties›

definition co_total          :: "'a ⇒ bool" where "co_total x ≡ x * bot = bot"
definition up_closed         :: "'a ⇒ bool" where "up_closed x ≡ x * 1 = x"
definition sup_distributive  :: "'a ⇒ bool" where "sup_distributive x ≡ (∀y z . x * (y ⊔ z) = x * y ⊔ x * z)"
definition inf_distributive  :: "'a ⇒ bool" where "inf_distributive x ≡ (∀y z . x * (y ⊓ z) = x * y ⊓ x * z)"
definition contact           :: "'a ⇒ bool" where "contact x ≡ x * x ⊔ 1 = x"
definition kernel            :: "'a ⇒ bool" where "kernel x ≡ x * x ⊓ 1 = x * 1"
definition sup_dist_contact  :: "'a ⇒ bool" where "sup_dist_contact x ≡ sup_distributive x ∧ contact x"
definition inf_dist_kernel   :: "'a ⇒ bool" where "inf_dist_kernel x ≡ inf_distributive x ∧ kernel x"
definition test              :: "'a ⇒ bool" where "test x ≡ x * top ⊓ 1 = x"
definition co_test           :: "'a ⇒ bool" where "co_test x ≡ x * bot ⊔ 1 = x"
definition co_vector         :: "'a ⇒ bool" where "co_vector x ≡ x * bot = x"

text ‹AAMP Theorem 6 / Figure 2: relations between properties›

lemma reflexive_total:
  "reflexive x ⟹ total x"
  using sup_left_divisibility total_sup_closed by force

lemma reflexive_dense:
  "reflexive x ⟹ dense_rel x"
  using mult_left_isotone by fastforce

lemma reflexive_transitive_up_closed:
  "reflexive x ⟹ transitive x ⟹ up_closed x"
  by (metis antisym_conv mult_isotone mult_sub_right_one reflexive_dense up_closed_def)

lemma coreflexive_co_total:
  "coreflexive x ⟹ co_total x"
  by (metis co_total_def order.eq_iff mult_left_isotone mult_left_one bot_least)

lemma coreflexive_transitive:
  "coreflexive x ⟹ transitive x"
  by (simp add: coreflexive_transitive)

lemma idempotent_transitive_dense:
  "idempotent x ⟷ transitive x ∧ dense_rel x"
  by (simp add: order.eq_iff)

lemma contact_reflexive:
  "contact x ⟹ reflexive x"
  using contact_def sup_right_divisibility by auto

lemma contact_transitive:
  "contact x ⟹ transitive x"
  using contact_def sup_left_divisibility by blast

lemma contact_dense:
  "contact x ⟹ dense_rel x"
  by (simp add: contact_reflexive reflexive_dense)

lemma contact_idempotent:
  "contact x ⟹ idempotent x"
  by (simp add: contact_dense contact_transitive idempotent_transitive_dense)

lemma contact_up_closed:
  "contact x ⟹ up_closed x"
  by (simp add: contact_reflexive contact_transitive reflexive_transitive_up_closed)

lemma contact_reflexive_idempotent_up_closed:
  "contact x ⟷ reflexive x ∧ idempotent x ∧ up_closed x"
  by (metis contact_def contact_idempotent contact_reflexive contact_up_closed sup_absorb2 sup_monoid.add_commute)

lemma kernel_coreflexive:
  "kernel x ⟹ coreflexive x"
  by (metis kernel_def inf.boundedE mult_sub_right_one)

lemma kernel_transitive:
  "kernel x ⟹ transitive x"
  by (simp add: coreflexive_transitive kernel_coreflexive)

lemma kernel_dense:
  "kernel x ⟹ dense_rel x"
  by (metis kernel_def inf.boundedE mult_sub_right_one)

lemma kernel_idempotent:
  "kernel x ⟹ idempotent x"
  by (simp add: idempotent_transitive_dense kernel_dense kernel_transitive)

lemma kernel_up_closed:
  "kernel x ⟹ up_closed x"
  by (metis kernel_coreflexive kernel_def kernel_idempotent inf.absorb1 up_closed_def)

lemma kernel_coreflexive_idempotent_up_closed:
  "kernel x ⟷ coreflexive x ∧ idempotent x ∧ up_closed x"
  by (metis kernel_coreflexive kernel_def kernel_idempotent inf.absorb1 up_closed_def)

lemma test_coreflexive:
  "test x ⟹ coreflexive x"
  using inf.sup_right_divisibility test_def by blast

lemma test_up_closed:
  "test x ⟹ up_closed x"
  by (metis order.eq_iff mult_left_one mult_sub_right_one mult_right_sub_dist_inf test_def top_mult_right_one up_closed_def)

lemma co_test_reflexive:
  "co_test x ⟹ reflexive x"
  using co_test_def sup_right_divisibility by blast

lemma co_test_transitive:
  "co_test x ⟹ transitive x"
  by (smt co_test_def sup_assoc le_iff_sup mult_left_one mult_left_zero mult_right_dist_sup mult_semi_associative)

lemma co_test_idempotent:
  "co_test x ⟹ idempotent x"
  by (simp add: co_test_reflexive co_test_transitive idempotent_transitive_dense reflexive_dense)

lemma co_test_up_closed:
  "co_test x ⟹ up_closed x"
  by (simp add: co_test_reflexive co_test_transitive reflexive_transitive_up_closed)

lemma co_test_contact:
  "co_test x ⟹ contact x"
  by (simp add: co_test_idempotent co_test_reflexive co_test_up_closed contact_reflexive_idempotent_up_closed)

lemma vector_transitive:
  "vector x ⟹ transitive x"
  by (metis mult_right_isotone top.extremum)

lemma vector_up_closed:
  "vector x ⟹ up_closed x"
  by (metis top_mult_right_one up_closed_def)

text ‹AAMP Theorem 10 / Figure 3: closure properties›

text ‹total›

lemma one_total:
  "total 1"
  by simp

lemma top_total:
  "total top"
  by simp

lemma sup_total:
  "total x ⟹ total y ⟹ total (x ⊔ y)"
  by (simp add: total_sup_closed)

text ‹co-total›

lemma zero_co_total:
  "co_total bot"
  by (simp add: co_total_def)

lemma one_co_total:
  "co_total 1"
  by (simp add: co_total_def)

lemma sup_co_total:
  "co_total x ⟹ co_total y ⟹ co_total (x ⊔ y)"
  by (simp add: co_total_def mult_right_dist_sup)

lemma inf_co_total:
  "co_total x ⟹ co_total y ⟹ co_total (x ⊓ y)"
  by (metis co_total_def order.antisym bot_least mult_right_sub_dist_inf_right)

lemma comp_co_total:
  "co_total x ⟹ co_total y ⟹ co_total (x * y)"
  by (metis co_total_def order.eq_iff mult_semi_associative bot_least)

text ‹sub-transitive›

lemma zero_transitive:
  "transitive bot"
  by (simp add: vector_transitive)

lemma one_transitive:
  "transitive 1"
  by simp

lemma top_transitive:
  "transitive top"
  by simp

lemma inf_transitive:
  "transitive x ⟹ transitive y ⟹ transitive (x ⊓ y)"
  by (meson inf_mono order_trans mult_left_sub_dist_inf_left mult_left_sub_dist_inf_right mult_right_sub_dist_inf)

text ‹dense›

lemma zero_dense:
  "dense_rel bot"
  by simp

lemma one_dense:
  "dense_rel 1"
  by simp

lemma top_dense:
  "dense_rel top"
  by simp

lemma sup_dense:
  assumes "dense_rel x"
      and "dense_rel y"
    shows "dense_rel (x ⊔ y)"
proof -
  have "x ≤ x * x ∧ y ≤ y * y"
    using assms by auto
  hence "x ≤ (x ⊔ y) * (x ⊔ y) ∧ y ≤ (x ⊔ y) * (x ⊔ y)"
    by (meson dense_sup_closed order_trans sup.cobounded1 sup.cobounded2)
  hence "x ⊔ y ≤ (x ⊔ y) * (x ⊔ y)"
    by simp
  thus "dense_rel (x ⊔ y)"
    by simp
qed

text ‹reflexive›

lemma one_reflexive:
  "reflexive 1"
  by simp

lemma top_reflexive:
  "reflexive top"
  by simp

lemma sup_reflexive:
  "reflexive x ⟹ reflexive y ⟹ reflexive (x ⊔ y)"
  by (simp add: reflexive_sup_closed)

lemma inf_reflexive:
  "reflexive x ⟹ reflexive y ⟹ reflexive (x ⊓ y)"
  by simp

lemma comp_reflexive:
  "reflexive x ⟹ reflexive y ⟹ reflexive (x * y)"
  using reflexive_mult_closed by auto

text ‹co-reflexive›

lemma zero_coreflexive:
  "coreflexive bot"
  by simp

lemma one_coreflexive:
  "coreflexive 1"
  by simp

lemma sup_coreflexive:
  "coreflexive x ⟹ coreflexive y ⟹ coreflexive (x ⊔ y)"
  by simp

lemma inf_coreflexive:
  "coreflexive x ⟹ coreflexive y ⟹ coreflexive (x ⊓ y)"
  by (simp add: le_infI1)

lemma comp_coreflexive:
  "coreflexive x ⟹ coreflexive y ⟹ coreflexive (x * y)"
  by (simp add: coreflexive_mult_closed)

text ‹idempotent›

lemma zero_idempotent:
  "idempotent bot"
  by simp

lemma one_idempotent:
  "idempotent 1"
  by simp

lemma top_idempotent:
  "idempotent top"
  by simp

text ‹up-closed›

lemma zero_up_closed:
  "up_closed bot"
  by (simp add: up_closed_def)

lemma one_up_closed:
  "up_closed 1"
  by (simp add: up_closed_def)

lemma top_up_closed:
  "up_closed top"
  by (simp add: vector_up_closed)

lemma sup_up_closed:
  "up_closed x ⟹ up_closed y ⟹ up_closed (x ⊔ y)"
  by (simp add: mult_right_dist_sup up_closed_def)

lemma inf_up_closed:
  "up_closed x ⟹ up_closed y ⟹ up_closed (x ⊓ y)"
  by (metis order.antisym mult_sub_right_one mult_right_sub_dist_inf up_closed_def)

lemma comp_up_closed:
  "up_closed x ⟹ up_closed y ⟹ up_closed (x * y)"
  by (metis order.antisym mult_semi_associative mult_sub_right_one up_closed_def)

text ‹add-distributive›

lemma zero_sup_distributive:
  "sup_distributive bot"
  by (simp add: sup_distributive_def)

lemma one_sup_distributive:
  "sup_distributive 1"
  by (simp add: sup_distributive_def)

lemma sup_sup_distributive:
  "sup_distributive x ⟹ sup_distributive y ⟹ sup_distributive (x ⊔ y)"
  using sup_distributive_def mult_right_dist_sup sup_monoid.add_assoc sup_monoid.add_commute by auto

text ‹inf-distributive›

lemma zero_inf_distributive:
  "inf_distributive bot"
  by (simp add: inf_distributive_def)

lemma one_inf_distributive:
  "inf_distributive 1"
  by (simp add: inf_distributive_def)

text ‹contact›

lemma one_contact:
  "contact 1"
  by (simp add: contact_def)

lemma top_contact:
  "contact top"
  by (simp add: contact_def)

lemma inf_contact:
  "contact x ⟹ contact y ⟹ contact (x ⊓ y)"
  by (meson contact_reflexive_idempotent_up_closed contact_transitive inf_reflexive inf_transitive inf_up_closed preorder_idempotent)

text ‹kernel›

lemma zero_kernel:
  "kernel bot"
  by (simp add: kernel_def)

lemma one_kernel:
  "kernel 1"
  by (simp add: kernel_def)

lemma sup_kernel:
  "kernel x ⟹ kernel y ⟹ kernel (x ⊔ y)"
  using kernel_coreflexive_idempotent_up_closed order.antisym coreflexive_transitive sup_dense sup_up_closed by force

text ‹add-distributive contact›

lemma one_sup_dist_contact:
  "sup_dist_contact 1"
  by (simp add: sup_dist_contact_def one_sup_distributive one_contact)

text ‹inf-distributive kernel›

lemma zero_inf_dist_kernel:
  "inf_dist_kernel bot"
  by (simp add: inf_dist_kernel_def zero_kernel zero_inf_distributive)

lemma one_inf_dist_kernel:
  "inf_dist_kernel 1"
  by (simp add: inf_dist_kernel_def one_kernel one_inf_distributive)

text ‹test›

lemma zero_test:
  "test bot"
  by (simp add: test_def)

lemma one_test:
  "test 1"
  by (simp add: test_def)

lemma sup_test:
  "test x ⟹ test y ⟹ test (x ⊔ y)"
  by (simp add: inf_sup_distrib2 mult_right_dist_sup test_def)

lemma inf_test:
  "test x ⟹ test y ⟹ test (x ⊓ y)"
  by (smt (z3) inf.left_commute idempotent_one_closed inf.le_iff_sup inf_top.right_neutral mult_right_isotone mult_sub_right_one mult_right_sub_dist_inf test_def top_mult_right_one)

text ‹co-test›

lemma one_co_test:
  "co_test 1"
  by (simp add: co_test_def)

lemma sup_co_test:
  "co_test x ⟹ co_test y ⟹ co_test (x ⊔ y)"
  by (smt (z3) co_test_def mult_right_dist_sup sup.left_idem sup_assoc sup_commute)

text ‹vector›

lemma zero_vector:
  "vector bot"
  by simp

lemma top_vector:
  "vector top"
  by simp

lemma sup_vector:
  "vector x ⟹ vector y ⟹ vector (x ⊔ y)"
  by (simp add: vector_sup_closed)

lemma inf_vector:
  "vector x ⟹ vector y ⟹ vector (x ⊓ y)"
  by (metis order.antisym top_right_mult_increasing mult_right_sub_dist_inf)

lemma comp_vector:
  "vector y ⟹ vector (x * y)"
  by (simp add: vector_mult_closed)

end

class lattice_ordered_pre_left_semiring_1 = non_associative_left_semiring + bounded_distrib_lattice +
  assumes mult_associative_one: "x * (y * z) = (x * (y * 1)) * z"
  assumes mult_right_dist_inf_one: "(x * 1 ⊓ y * 1) * z = x * z ⊓ y * z"
begin

subclass pre_left_semiring
  apply unfold_locales
  by (metis mult_associative_one mult_left_isotone mult_right_isotone mult_sub_right_one)

subclass lattice_ordered_pre_left_semiring ..

lemma mult_zero_associative:
  "x * bot * y = x * bot"
  by (metis mult_associative_one mult_left_zero)

lemma mult_zero_sup_one_dist:
  "(x * bot ⊔ 1) * z = x * bot ⊔ z"
  by (simp add: mult_right_dist_sup mult_zero_associative)

lemma mult_zero_sup_dist:
  "(x * bot ⊔ y) * z = x * bot ⊔ y * z"
  by (simp add: mult_right_dist_sup mult_zero_associative)

lemma vector_zero_inf_one_comp:
  "(x * bot ⊓ 1) * y = x * bot ⊓ y"
  by (metis mult_left_one mult_right_dist_inf_one mult_zero_associative)

text ‹AAMP Theorem 6 / Figure 2: relations between properties›

lemma co_test_inf_distributive:
  "co_test x ⟹ inf_distributive x"
  by (metis co_test_def distrib_imp1 inf_sup_distrib1 inf_distributive_def mult_zero_sup_one_dist)

lemma co_test_sup_distributive:
  "co_test x ⟹ sup_distributive x"
  by (metis sup_sup_distributive sup_distributive_def co_test_def one_sup_distributive sup.idem mult_zero_associative)

lemma co_test_sup_dist_contact:
  "co_test x ⟹ sup_dist_contact x"
  by (simp add: co_test_sup_distributive sup_dist_contact_def co_test_contact)

text ‹AAMP Theorem 10 / Figure 3: closure properties›

text ‹co-test›

lemma inf_co_test:
  "co_test x ⟹ co_test y ⟹ co_test (x ⊓ y)"
  by (smt (z3) co_test_def co_test_up_closed mult_right_dist_inf_one sup_commute sup_inf_distrib1 up_closed_def)

lemma comp_co_test:
  "co_test x ⟹ co_test y ⟹ co_test (x * y)"
  by (metis co_test_def mult_associative_one sup_assoc mult_zero_sup_one_dist)

end

class lattice_ordered_pre_left_semiring_2 = lattice_ordered_pre_left_semiring +
  assumes mult_sub_associative_one: "x * (y * z) ≤ (x * (y * 1)) * z"
  assumes mult_right_dist_inf_one_sub: "x * z ⊓ y * z ≤ (x * 1 ⊓ y * 1) * z"
begin

subclass lattice_ordered_pre_left_semiring_1
  apply unfold_locales
  apply (simp add: order.antisym mult_sub_associative_one mult_sup_associative_one)
  by (metis order.eq_iff mult_one_associative mult_right_dist_inf_one_sub mult_right_sub_dist_inf)

end

class multirelation_algebra_1 = lattice_ordered_pre_left_semiring +
  assumes mult_left_top: "top * x = top"
begin

text ‹AAMP Theorem 10 / Figure 3: closure properties›

lemma top_sup_distributive:
  "sup_distributive top"
  by (simp add: sup_distributive_def mult_left_top)

lemma top_inf_distributive:
  "inf_distributive top"
  by (simp add: inf_distributive_def mult_left_top)

lemma top_sup_dist_contact:
  "sup_dist_contact top"
  by (simp add: sup_dist_contact_def top_contact top_sup_distributive)

lemma top_co_test:
  "co_test top"
  by (simp add: co_test_def mult_left_top)

end

text ‹M1-algebra›

class multirelation_algebra_2 = multirelation_algebra_1 + lattice_ordered_pre_left_semiring_2
begin

lemma mult_top_associative:
  "x * top * y = x * top"
  by (metis mult_left_top mult_associative_one)

lemma vector_inf_one_comp:
  "(x * top ⊓ 1) * y = x * top ⊓ y"
  by (metis vector_zero_inf_one_comp mult_top_associative)

lemma vector_left_annihilator:
  "vector x ⟹ x * y = x"
  by (metis mult_top_associative)

text ‹properties›

lemma test_comp_inf:
  "test x ⟹ test y ⟹ x * y = x ⊓ y"
  by (metis inf.absorb1 inf.left_commute test_coreflexive test_def vector_inf_one_comp)

text ‹AAMP Theorem 6 / Figure 2: relations between properties›

lemma test_sup_distributive:
  "test x ⟹ sup_distributive x"
  by (metis sup_distributive_def inf_sup_distrib1 test_def vector_inf_one_comp)

lemma test_inf_distributive:
  "test x ⟹ inf_distributive x"
  by (smt (verit, ccfv_SIG) inf.commute inf.sup_monoid.add_assoc inf_distributive_def test_def inf.idem vector_inf_one_comp)

lemma test_inf_dist_kernel:
  "test x ⟹ inf_dist_kernel x"
  by (simp add: kernel_def inf_dist_kernel_def one_test test_comp_inf test_inf_distributive)

lemma vector_idempotent:
  "vector x ⟹ idempotent x"
  using vector_left_annihilator by blast

lemma vector_sup_distributive:
  "vector x ⟹ sup_distributive x"
  by (simp add: sup_distributive_def vector_left_annihilator)

lemma vector_inf_distributive:
  "vector x ⟹ inf_distributive x"
  by (simp add: inf_distributive_def vector_left_annihilator)

lemma vector_co_vector:
  "vector x ⟷ co_vector x"
  by (metis co_vector_def mult_zero_associative mult_top_associative)

text ‹AAMP Theorem 10 / Figure 3: closure properties›

text ‹test›

lemma comp_test:
  "test x ⟹ test y ⟹ test (x * y)"
  by (simp add: inf_test test_comp_inf)

end

class dual =
  fixes dual :: "'a ⇒ 'a" ("_⇧^d" [100] 100)

class multirelation_algebra_3 = lattice_ordered_pre_left_semiring + dual +
  assumes dual_involutive: "x⇧^d⇧^d = x"
  assumes dual_dist_sup: "(x ⊔ y)⇧^d = x⇧^d ⊓ y⇧^d"
  assumes dual_one: "1⇧^d = 1"
begin

lemma dual_dist_inf:
  "(x ⊓ y)⇧^d = x⇧^d ⊔ y⇧^d"
  by (metis dual_dist_sup dual_involutive)

lemma dual_antitone:
  "x ≤ y ⟹ y⇧^d ≤ x⇧^d"
  using dual_dist_sup sup_right_divisibility by fastforce

lemma dual_zero:
  "bot⇧^d = top"
  by (metis dual_antitone bot_least dual_involutive top_le)

lemma dual_top:
  "top⇧^d = bot"
  using dual_zero dual_involutive by auto

text ‹AAMP Theorem 10 / Figure 3: closure properties›

lemma reflexive_coreflexive_dual:
  "reflexive x ⟷ coreflexive (x⇧^d)"
  using dual_antitone dual_involutive dual_one by fastforce

end

class multirelation_algebra_4 = multirelation_algebra_3 +
  assumes dual_sub_dist_comp: "(x * y)⇧^d ≤ x⇧^d * y⇧^d"
begin

subclass multirelation_algebra_1
  apply unfold_locales
  by (metis order.antisym top.extremum dual_zero dual_sub_dist_comp dual_involutive mult_left_zero)

lemma dual_sub_dist_comp_one:
  "(x * y)⇧^d ≤ (x * 1)⇧^d * y⇧^d"
  by (metis dual_sub_dist_comp mult_one_associative)

text ‹AAMP Theorem 10 / Figure 3: closure properties›

lemma co_total_total_dual:
  "co_total x ⟹ total (x⇧^d)"
  by (metis co_total_def dual_sub_dist_comp dual_zero top_le)

lemma transitive_dense_dual:
  "transitive x ⟹ dense_rel (x⇧^d)"
  using dual_antitone dual_sub_dist_comp inf.order_lesseq_imp by blast

end

text ‹M2-algebra›

class multirelation_algebra_5 = multirelation_algebra_3 +
  assumes dual_dist_comp_one: "(x * y)⇧^d = (x * 1)⇧^d * y⇧^d"
begin

subclass multirelation_algebra_4
  apply unfold_locales
  by (metis dual_antitone mult_sub_right_one mult_left_isotone dual_dist_comp_one)

lemma strong_up_closed:
  "x * 1 ≤ x ⟹ x⇧^d * y⇧^d ≤ (x * y)⇧^d"
  by (simp add: dual_dist_comp_one antisym_conv mult_sub_right_one)

lemma strong_up_closed_2:
  "up_closed x ⟹ (x * y)⇧^d = x⇧^d * y⇧^d"
  by (simp add: dual_dist_comp_one up_closed_def)

subclass lattice_ordered_pre_left_semiring_2
  apply unfold_locales
  apply (smt comp_up_closed dual_antitone dual_dist_comp_one dual_involutive dual_one mult_left_one mult_one_associative mult_semi_associative up_closed_def strong_up_closed_2)
  by (smt dual_dist_comp_one dual_dist_inf dual_involutive eq_refl mult_one_associative mult_right_dist_sup)

text ‹AAMP Theorem 8›

subclass multirelation_algebra_2 ..

text ‹AAMP Theorem 10 / Figure 3: closure properties›

text ‹up-closed›

lemma dual_up_closed:
  "up_closed x ⟷ up_closed (x⇧^d)"
  by (metis dual_involutive dual_one up_closed_def strong_up_closed_2)

text ‹contact›

lemma contact_kernel_dual:
  "contact x ⟷ kernel (x⇧^d)"
  by (metis contact_def contact_up_closed dual_dist_sup dual_involutive dual_one kernel_def kernel_up_closed up_closed_def strong_up_closed_2)

text ‹add-distributive contact›

lemma sup_dist_contact_inf_dist_kernel_dual:
  "sup_dist_contact x ⟷ inf_dist_kernel (x⇧^d)"
proof
  assume 1: "sup_dist_contact x"
  hence 2: "up_closed x"
    using sup_dist_contact_def contact_up_closed by auto
  have "sup_distributive x"
    using 1 sup_dist_contact_def by auto
  hence "inf_distributive (x⇧^d)"
    using 2 by (smt sup_distributive_def dual_dist_comp_one dual_dist_inf dual_involutive inf_distributive_def up_closed_def)
  thus "inf_dist_kernel (x⇧^d)"
    using 1 contact_kernel_dual sup_dist_contact_def inf_dist_kernel_def by blast
next
  assume 3: "inf_dist_kernel (x⇧^d)"
  hence 4: "up_closed (x⇧^d)"
    using kernel_up_closed inf_dist_kernel_def by auto
  have "inf_distributive (x⇧^d)"
    using 3 inf_dist_kernel_def by auto
  hence "sup_distributive (x⇧^d⇧^d)"
    using 4 by (smt inf_distributive_def sup_distributive_def dual_dist_sup dual_involutive strong_up_closed_2)
  thus "sup_dist_contact x"
    using 3 contact_kernel_dual sup_dist_contact_def dual_involutive inf_dist_kernel_def by auto
qed

text ‹test›

lemma test_co_test_dual:
  "test x ⟷ co_test (x⇧^d)"
  by (smt (z3) co_test_def co_test_up_closed dual_dist_comp_one dual_dist_inf dual_involutive dual_one dual_top test_def test_up_closed up_closed_def)

text ‹vector›

lemma vector_dual:
  "vector x ⟷ vector (x⇧^d)"
  by (metis dual_dist_comp_one dual_involutive mult_top_associative)

end

class multirelation_algebra_6 = multirelation_algebra_4 +
  assumes dual_sub_dist_comp_one: "(x * 1)⇧^d * y⇧^d ≤ (x * y)⇧^d"
begin

subclass multirelation_algebra_5
  apply unfold_locales
  by (metis dual_sub_dist_comp dual_sub_dist_comp_one order.eq_iff mult_one_associative)

(*
lemma "dense_rel x ∧ coreflexive x ⟶ up_closed x" nitpick [expect=genuine,card=5] oops
lemma "x * top ⊓ y * z ≤ (x * top ⊓ y) * z" nitpick [expect=genuine,card=8] oops
*)

end

text ‹M3-algebra›

class up_closed_multirelation_algebra = multirelation_algebra_3 +
  assumes dual_dist_comp: "(x * y)⇧^d = x⇧^d * y⇧^d"
begin

lemma mult_right_dist_inf:
  "(x ⊓ y) * z = x * z ⊓ y * z"
  by (metis dual_dist_sup dual_dist_comp dual_involutive mult_right_dist_sup)

text ‹AAMP Theorem 9›

subclass idempotent_left_semiring
  apply unfold_locales
  apply (metis order.antisym dual_antitone dual_dist_comp dual_involutive mult_semi_associative)
  apply simp
  by (metis order.antisym dual_antitone dual_dist_comp dual_involutive dual_one mult_sub_right_one)

subclass multirelation_algebra_6
  apply unfold_locales
  by (simp_all add: dual_dist_comp)

lemma vector_inf_comp:
  "(x * top ⊓ y) * z = x * top ⊓ y * z"
  by (simp add: vector_left_annihilator mult_right_dist_inf mult.assoc)

lemma vector_zero_inf_comp:
  "(x * bot ⊓ y) * z = x * bot ⊓ y * z"
  by (simp add: mult_right_dist_inf mult.assoc)

text ‹AAMP Theorem 10 / Figure 3: closure properties›

text ‹total›

lemma inf_total:
  "total x ⟹ total y ⟹ total (x ⊓ y)"
  by (simp add: mult_right_dist_inf)

lemma comp_total:
  "total x ⟹ total y ⟹ total (x * y)"
  by (simp add: mult_assoc)

lemma total_co_total_dual:
  "total x ⟷ co_total (x⇧^d)"
  by (metis co_total_def dual_dist_comp dual_involutive dual_top)

text ‹dense›

lemma transitive_iff_dense_dual:
  "transitive x ⟷ dense_rel (x⇧^d)"
  by (metis dual_antitone dual_dist_comp dual_involutive)

text ‹idempotent›

lemma idempotent_dual:
  "idempotent x ⟷ idempotent (x⇧^d)"
  using dual_involutive idempotent_transitive_dense transitive_iff_dense_dual by auto

text ‹add-distributive›

lemma comp_sup_distributive:
  "sup_distributive x ⟹ sup_distributive y ⟹ sup_distributive (x * y)"
  by (simp add: sup_distributive_def mult.assoc)

lemma sup_inf_distributive_dual:
  "sup_distributive x ⟷ inf_distributive (x⇧^d)"
  by (smt (verit, ccfv_threshold) sup_distributive_def dual_dist_sup dual_dist_comp dual_dist_inf dual_involutive inf_distributive_def)

text ‹inf-distributive›

lemma inf_inf_distributive:
  "inf_distributive x ⟹ inf_distributive y ⟹ inf_distributive (x ⊓ y)"
  by (metis sup_inf_distributive_dual sup_sup_distributive dual_dist_inf dual_involutive)

lemma comp_inf_distributive:
  "inf_distributive x ⟹ inf_distributive y ⟹ inf_distributive (x * y)"
  by (simp add: inf_distributive_def mult.assoc)

(*
lemma "co_total x ∧ transitive x ∧ up_closed x ⟶ coreflexive x" nitpick [expect=genuine,card=5] oops
lemma "total x ∧ dense_rel x ∧ up_closed x ⟶ reflexive x" nitpick [expect=genuine,card=5] oops
lemma "x * top ⊓ x⇧^d * bot = bot" nitpick [expect=genuine,card=6] oops
*)

end

class multirelation_algebra_7 = multirelation_algebra_4 +
  assumes vector_inf_comp: "(x * top ⊓ y) * z = x * top ⊓ y * z"
begin

lemma vector_zero_inf_comp:
  "(x * bot ⊓ y) * z = x * bot ⊓ y * z"
  by (metis vector_inf_comp vector_mult_closed zero_vector)

lemma test_sup_distributive:
  "test x ⟹ sup_distributive x"
  by (metis sup_distributive_def inf_sup_distrib1 mult_left_one test_def vector_inf_comp)

lemma test_inf_distributive:
  "test x ⟹ inf_distributive x"
  by (smt (z3) inf.right_idem inf.sup_monoid.add_assoc inf.sup_monoid.add_commute inf_distributive_def mult_left_one test_def vector_inf_comp)

lemma test_inf_dist_kernel:
  "test x ⟹ inf_dist_kernel x"
  by (metis inf.idem inf.sup_monoid.add_assoc kernel_def inf_dist_kernel_def mult_left_one test_def test_inf_distributive vector_inf_comp)

lemma co_test_inf_distributive:
  assumes "co_test x"
    shows "inf_distributive x"
proof -
  have "x = x * bot ⊔ 1"
    using assms co_test_def by auto
  hence "∀y z . x * y ⊓ x * z = x * (y ⊓ z)"
    by (metis distrib_imp1 inf_sup_absorb inf_sup_distrib1 mult_left_one mult_left_top mult_right_dist_sup sup_top_right vector_zero_inf_comp)
  thus "inf_distributive x"
    by (simp add: inf_distributive_def)
qed

lemma co_test_sup_distributive:
  assumes "co_test x"
    shows "sup_distributive x"
proof -
  have "x = x * bot ⊔ 1"
    using assms co_test_def by auto
  hence "∀y z . x * (y ⊔ z) = x * y ⊔ x * z"
    by (metis sup_sup_distributive sup_distributive_def inf_sup_absorb mult_left_top one_sup_distributive sup.idem sup_top_right vector_zero_inf_comp)
  thus "sup_distributive x"
    by (simp add: sup_distributive_def)
qed

lemma co_test_sup_dist_contact:
  "co_test x ⟹ sup_dist_contact x"
  by (simp add: sup_dist_contact_def co_test_sup_distributive co_test_contact)

end

end

Theory Boolean_Semirings

(* Title:      Boolean Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Boolean Semirings›

theory Boolean_Semirings

imports Stone_Algebras.P_Algebras Lattice_Ordered_Semirings

begin

class complemented_distributive_lattice = bounded_distrib_lattice + uminus +
  assumes inf_complement: "x ⊓ (-x) = bot"
  assumes sup_complement: "x ⊔ (-x) = top"
begin

sublocale boolean_algebra where minus = "λx y . x ⊓ (-y)" and inf = inf and sup = sup and bot = bot and top = top
  apply unfold_locales
  apply (simp add: inf_complement)
  apply (simp add: sup_complement)
  by simp

end

text ‹M0-algebra›

context lattice_ordered_pre_left_semiring
begin

text ‹Section 7›

lemma vector_1:
  "vector x ⟷ x * top ≤ x"
  by (simp add: antisym_conv top_right_mult_increasing)

definition zero_vector :: "'a ⇒ bool" where "zero_vector x ≡ x ≤ x * bot"
definition one_vector :: "'a ⇒ bool" where "one_vector x ≡ x * bot ≤ x"

lemma zero_vector_left_zero:
  assumes "zero_vector x"
    shows "x * y = x * bot"
proof -
  have "x * y ≤ x * bot"
    by (metis assms mult_isotone top.extremum vector_mult_closed zero_vector zero_vector_def)
  thus ?thesis
    by (simp add: order.antisym mult_right_isotone)
qed

lemma zero_vector_1:
  "zero_vector x ⟷ (∀y . x * y = x * bot)"
  by (metis top_right_mult_increasing zero_vector_def zero_vector_left_zero)

lemma zero_vector_2:
  "zero_vector x ⟷ (∀y . x * y ≤ x * bot)"
  by (metis eq_refl order_trans top_right_mult_increasing zero_vector_def zero_vector_left_zero)

lemma zero_vector_3:
  "zero_vector x ⟷ x * 1 = x * bot"
  by (metis mult_sub_right_one zero_vector_def zero_vector_left_zero)

lemma zero_vector_4:
  "zero_vector x ⟷ x * 1 ≤ x * bot"
  using order.antisym mult_right_isotone zero_vector_3 by auto

lemma zero_vector_5:
  "zero_vector x ⟷ x * top = x * bot"
  by (metis top_right_mult_increasing zero_vector_def zero_vector_left_zero)

lemma zero_vector_6:
  "zero_vector x ⟷ x * top ≤ x * bot"
  by (meson mult_right_isotone order_trans top.extremum zero_vector_2)

lemma zero_vector_7:
  "zero_vector x ⟷ (∀y . x * top = x * y)"
  by (metis zero_vector_1)

lemma zero_vector_8:
  "zero_vector x ⟷ (∀y . x * top ≤ x * y)"
  by (metis zero_vector_6 zero_vector_left_zero)

lemma zero_vector_9:
  "zero_vector x ⟷ (∀y . x * 1 = x * y)"
  by (metis zero_vector_1)

lemma zero_vector_0:
  "zero_vector x ⟷ (∀y z . x * y = x * z)"
  by (metis zero_vector_5 zero_vector_left_zero)

text ‹Theorem 6 / Figure 2: relations between properties›

lemma co_vector_zero_vector_one_vector:
  "co_vector x ⟷ zero_vector x ∧ one_vector x"
  using co_vector_def one_vector_def zero_vector_def by auto

lemma up_closed_one_vector:
  "up_closed x ⟹ one_vector x"
  by (metis bot_least mult_right_isotone up_closed_def one_vector_def)

lemma zero_vector_dense:
  "zero_vector x ⟹ dense_rel x"
  by (metis zero_vector_0 zero_vector_def)

lemma zero_vector_sup_distributive:
  "zero_vector x ⟹ sup_distributive x"
  by (metis sup_distributive_def sup_idem zero_vector_0)

lemma zero_vector_inf_distributive:
  "zero_vector x ⟹ inf_distributive x"
  by (metis inf_idem inf_distributive_def zero_vector_0)

lemma up_closed_zero_vector_vector:
  "up_closed x ⟹ zero_vector x ⟹ vector x"
  by (metis up_closed_def zero_vector_0)

lemma zero_vector_one_vector_vector:
  "zero_vector x ⟹ one_vector x ⟹ vector x"
  by (metis one_vector_def vector_1 zero_vector_0)

lemma co_vector_vector:
  "co_vector x ⟹ vector x"
  by (simp add: co_vector_zero_vector_one_vector zero_vector_one_vector_vector)

text ‹Theorem 10 / Figure 3: closure properties›

text ‹zero-vector›

lemma zero_zero_vector:
  "zero_vector bot"
  by (simp add: zero_vector_def)

lemma sup_zero_vector:
  "zero_vector x ⟹ zero_vector y ⟹ zero_vector (x ⊔ y)"
  by (simp add: mult_right_dist_sup zero_vector_3)

lemma comp_zero_vector:
  "zero_vector x ⟹ zero_vector y ⟹ zero_vector (x * y)"
  by (metis mult_one_associative zero_vector_0)

text ‹one-vector›

lemma zero_one_vector:
  "one_vector bot"
  by (simp add: one_vector_def)

lemma one_one_vector:
  "one_vector 1"
  by (simp add: one_up_closed up_closed_one_vector)

lemma top_one_vector:
  "one_vector top"
  by (simp add: one_vector_def)

lemma sup_one_vector:
  "one_vector x ⟹ one_vector y ⟹ one_vector (x ⊔ y)"
  by (simp add: mult_right_dist_sup order_trans one_vector_def)

lemma inf_one_vector:
  "one_vector x ⟹ one_vector y ⟹ one_vector (x ⊓ y)"
  by (meson order.trans inf.boundedI mult_right_sub_dist_inf_left mult_right_sub_dist_inf_right one_vector_def)

lemma comp_one_vector:
  "one_vector x ⟹ one_vector y ⟹ one_vector (x * y)"
  using mult_isotone mult_semi_associative order_lesseq_imp one_vector_def by blast

end

context multirelation_algebra_1
begin

text ‹Theorem 10 / Figure 3: closure properties›

text ‹zero-vector›

lemma top_zero_vector:
   "zero_vector top"
  by (simp add: mult_left_top zero_vector_def)

end

text ‹M1-algebra›

context multirelation_algebra_2
begin

text ‹Section 7›

lemma zero_vector_10:
  "zero_vector x ⟷ x * top = x * 1"
  by (metis mult_one_associative mult_top_associative zero_vector_7)

lemma zero_vector_11:
  "zero_vector x ⟷ x * top ≤ x * 1"
  using order.antisym mult_right_isotone zero_vector_10 by fastforce

text ‹Theorem 6 / Figure 2: relations between properties›

lemma vector_zero_vector:
  "vector x ⟹ zero_vector x"
  by (simp add: zero_vector_def vector_left_annihilator)

lemma vector_up_closed_zero_vector:
  "vector x ⟷ up_closed x ∧ zero_vector x"
  using up_closed_zero_vector_vector vector_up_closed vector_zero_vector by blast

lemma vector_zero_vector_one_vector:
  "vector x ⟷ zero_vector x ∧ one_vector x"
  by (simp add: co_vector_zero_vector_one_vector vector_co_vector)

(*
lemma "(x * bot ⊓ y) * 1 = x * bot ⊓ y * 1" nitpick [expect=genuine,card=7] oops
*)

end

text ‹M3-algebra›

context up_closed_multirelation_algebra
begin

lemma up_closed:
  "up_closed x"
  by (simp add: up_closed_def)

lemma dedekind_1_left:
  "x * 1 ⊓ y ≤ (x ⊓ y * 1) * 1"
  by simp

text ‹Theorem 10 / Figure 3: closure properties›

text ‹zero-vector›

lemma zero_vector_dual:
  "zero_vector x ⟷ zero_vector (x⇧^d)"
  using up_closed_zero_vector_vector vector_dual vector_zero_vector up_closed by blast

end

text ‹complemented M0-algebra›

class lattice_ordered_pre_left_semiring_b = lattice_ordered_pre_left_semiring + complemented_distributive_lattice
begin

definition down_closed :: "'a ⇒ bool" where "down_closed x ≡ -x * 1 ≤ -x"

text ‹Theorem 10 / Figure 3: closure properties›

text ‹down-closed›

lemma zero_down_closed:
  "down_closed bot"
  by (simp add: down_closed_def)

lemma top_down_closed:
  "down_closed top"
  by (simp add: down_closed_def)

lemma complement_down_closed_up_closed:
  "down_closed x ⟷ up_closed (-x)"
  using down_closed_def order.antisym mult_sub_right_one up_closed_def by auto

lemma sup_down_closed:
  "down_closed x ⟹ down_closed y ⟹ down_closed (x ⊔ y)"
  by (simp add: complement_down_closed_up_closed inf_up_closed)

lemma inf_down_closed:
  "down_closed x ⟹ down_closed y ⟹ down_closed (x ⊓ y)"
  by (simp add: complement_down_closed_up_closed sup_up_closed)

end

class multirelation_algebra_1b = multirelation_algebra_1 + complemented_distributive_lattice
begin

subclass lattice_ordered_pre_left_semiring_b ..

text ‹Theorem 7.1›

lemma complement_mult_zero_sub:
  "-(x * bot) ≤ -x * bot"
proof -
  have "top = -x * bot ⊔ x * bot"
    by (metis compl_sup_top mult_left_top mult_right_dist_sup)
  thus ?thesis
    by (simp add: heyting.implies_order sup.commute)
qed

text ‹Theorem 7.2›

lemma transitive_zero_vector_complement:
  "transitive x ⟹ zero_vector (-x)"
  by (meson complement_mult_zero_sub compl_mono mult_right_isotone order_trans zero_vector_def bot_least)

lemma transitive_dense_complement:
  "transitive x ⟹ dense_rel (-x)"
  by (simp add: zero_vector_dense transitive_zero_vector_complement)

lemma transitive_sup_distributive_complement:
  "transitive x ⟹ sup_distributive (-x)"
  by (simp add: zero_vector_sup_distributive transitive_zero_vector_complement)

lemma transitive_inf_distributive_complement:
  "transitive x ⟹ inf_distributive (-x)"
  by (simp add: zero_vector_inf_distributive transitive_zero_vector_complement)

lemma up_closed_zero_vector_complement:
  "up_closed x ⟹ zero_vector (-x)"
  by (meson complement_mult_zero_sub compl_le_swap2 one_vector_def order_trans up_closed_one_vector zero_vector_def)

lemma up_closed_dense_complement:
  "up_closed x ⟹ dense_rel (-x)"
  by (simp add: zero_vector_dense up_closed_zero_vector_complement)

lemma up_closed_sup_distributive_complement:
  "up_closed x ⟹ sup_distributive (-x)"
  by (simp add: zero_vector_sup_distributive up_closed_zero_vector_complement)

lemma up_closed_inf_distributive_complement:
  "up_closed x ⟹ inf_distributive (-x)"
  by (simp add: zero_vector_inf_distributive up_closed_zero_vector_complement)

text ‹Theorem 10 / Figure 3: closure properties›

text ‹closure under complement›

lemma co_total_total:
  "co_total x ⟹ total (-x)"
  by (metis complement_mult_zero_sub co_total_def compl_bot_eq mult_left_sub_dist_sup_right sup_bot_right top_le)

lemma complement_one_vector_zero_vector:
  "one_vector x ⟹ zero_vector (-x)"
  using compl_mono complement_mult_zero_sub one_vector_def order_trans zero_vector_def by blast

text ‹Theorem 6 / Figure 2: relations between properties›

lemma down_closed_zero_vector:
  "down_closed x ⟹ zero_vector x"
  using complement_down_closed_up_closed up_closed_zero_vector_complement by force

lemma down_closed_one_vector_vector:
  "down_closed x ⟹ one_vector x ⟹ vector x"
  by (simp add: down_closed_zero_vector zero_vector_one_vector_vector)

(*
lemma complement_vector: "vector x ⟶ vector (-x)" nitpick [expect=genuine,card=8] oops
*)

end

class multirelation_algebra_1c = multirelation_algebra_1b +
  assumes dedekind_top_left: "x * top ⊓ y ≤ (x ⊓ y * top) * top"
  assumes comp_zero_inf: "(x * bot ⊓ y) * bot ≤ (x ⊓ y) * bot"
begin

text ‹Theorem 7.3›

lemma schroeder_top_sub:
  "-(x * top) * top ≤ -x"
proof -
  have "-(x * top) * top ⊓ x ≤ bot"
    by (metis dedekind_top_left p_inf zero_vector)
  thus ?thesis
    by (simp add: shunting_1)
qed

text ‹Theorem 7.4›

lemma schroeder_top:
  "x * top ≤ y ⟷ -y * top ≤ -x"
  apply (rule iffI)
  using compl_mono inf.order_trans mult_left_isotone schroeder_top_sub apply blast
  by (metis compl_mono double_compl mult_left_isotone order_trans schroeder_top_sub)

text ‹Theorem 7.5›

lemma schroeder_top_eq:
  "-(x * top) * top = -(x * top)"
  using vector_1 vector_mult_closed vector_top_closed schroeder_top by auto

lemma schroeder_one_eq:
  "-(x * top) * 1 = -(x * top)"
  by (metis top_mult_right_one schroeder_top_eq)

text ‹Theorem 7.6›

lemma vector_inf_comp:
  "x * top ⊓ y * z = (x * top ⊓ y) * z"
proof (rule order.antisym)
  have "x * top ⊓ y * z = x * top ⊓ ((x * top ⊓ y) ⊔ (-(x * top) ⊓ y)) * z"
    by (simp add: inf_commute)
  also have "... = x * top ⊓ ((x * top ⊓ y) * z ⊔ (-(x * top) ⊓ y) * z)"
    by (simp add: inf_sup_distrib2 mult_right_dist_sup)
  also have "... = (x * top ⊓ (x * top ⊓ y) * z) ⊔ (x * top ⊓ (-(x * top) ⊓ y) * z)"
    by (simp add: inf_sup_distrib1)
  also have "... ≤ (x * top ⊓ y) * z ⊔ (x * top ⊓ (-(x * top) ⊓ y) * z)"
    by (simp add: le_infI2)
  also have "... ≤ (x * top ⊓ y) * z ⊔ (x * top ⊓ -(x * top) * z)"
    by (metis inf.sup_left_isotone inf_commute mult_right_sub_dist_inf_left sup_right_isotone)
  also have "... ≤ (x * top ⊓ y) * z ⊔ (x * top ⊓ -(x * top) * top)"
    using inf.sup_right_isotone mult_right_isotone sup_right_isotone by auto
  also have "... = (x * top ⊓ y) * z"
    by (simp add: schroeder_top_eq)
  finally show "x * top ⊓ y * z ≤ (x * top ⊓ y) * z"
    .
next
  show "(x * top ⊓ y) * z ≤ x * top ⊓ y * z"
    by (metis inf.bounded_iff mult_left_top mult_right_sub_dist_inf_left mult_right_sub_dist_inf_right mult_semi_associative order_lesseq_imp)
qed

(*
lemma dedekind_top_left:
  "x * top ⊓ y ≤ (x ⊓ y * top) * top"
  by (metis inf.commute top_right_mult_increasing vector_inf_comp)
*)

text ‹Theorem 7.7›

lemma vector_zero_inf_comp:
  "(x * bot ⊓ y) * z = x * bot ⊓ y * z"
  by (metis vector_inf_comp vector_mult_closed zero_vector)

lemma vector_zero_inf_comp_2:
  "(x * bot ⊓ y) * z = (x * bot ⊓ y * 1) * z"
  by (simp add: vector_zero_inf_comp)

text ‹Theorem 7.8›

lemma comp_zero_inf_2:
  "x * bot ⊓ y * bot = (x ⊓ y) * bot"
  using order.antisym mult_right_sub_dist_inf comp_zero_inf vector_zero_inf_comp by auto

lemma comp_zero_inf_3:
  "x * bot ⊓ y * bot = (x * bot ⊓ y) * bot"
  by (simp add: vector_zero_inf_comp)

lemma comp_zero_inf_4:
  "x * bot ⊓ y * bot = (x * bot ⊓ y * bot) * bot"
  by (metis comp_zero_inf_2 inf.commute vector_zero_inf_comp)

lemma comp_zero_inf_5:
  "x * bot ⊓ y * bot = (x * 1 ⊓ y * 1) * bot"
  by (metis comp_zero_inf_2 mult_one_associative)

lemma comp_zero_inf_6:
  "x * bot ⊓ y * bot = (x * 1 ⊓ y * bot) * bot"
  using inf.sup_monoid.add_commute vector_zero_inf_comp by fastforce

lemma comp_zero_inf_7:
  "x * bot ⊓ y * bot = (x * 1 ⊓ y) * bot"
  by (metis comp_zero_inf_2 mult_one_associative)

text ‹Theorem 10 / Figure 3: closure properties›

text ‹zero-vector›

lemma inf_zero_vector:
  "zero_vector x ⟹ zero_vector y ⟹ zero_vector (x ⊓ y)"
  by (metis comp_zero_inf_2 inf.sup_mono zero_vector_def)

text ‹down-closed›

lemma comp_down_closed:
  "down_closed x ⟹ down_closed y ⟹ down_closed (x * y)"
  by (metis complement_down_closed_up_closed down_closed_zero_vector up_closed_def zero_vector_0 schroeder_one_eq)

text ‹closure under complement›

lemma complement_vector:
  "vector x ⟷ vector (-x)"
  using vector_1 schroeder_top by blast

lemma complement_zero_vector_one_vector:
  "zero_vector x ⟹ one_vector (-x)"
  by (metis comp_zero_inf_2 order.antisym complement_mult_zero_sub double_compl inf.sup_monoid.add_commute mult_left_zero one_vector_def order.refl pseudo_complement top_right_mult_increasing zero_vector_0)

lemma complement_zero_vector_one_vector_iff:
  "zero_vector x ⟷ one_vector (-x)"
  using complement_zero_vector_one_vector complement_one_vector_zero_vector by force

lemma complement_one_vector_zero_vector_iff:
  "one_vector x ⟷ zero_vector (-x)"
  using complement_zero_vector_one_vector complement_one_vector_zero_vector by force

text ‹Theorem 6 / Figure 2: relations between properties›

lemma vector_down_closed:
  "vector x ⟹ down_closed x"
  using complement_vector complement_down_closed_up_closed vector_up_closed by blast

lemma co_vector_down_closed:
  "co_vector x ⟹ down_closed x"
  by (simp add: co_vector_vector vector_down_closed)

lemma vector_down_closed_one_vector:
  "vector x ⟷ down_closed x ∧ one_vector x"
  using down_closed_one_vector_vector up_closed_one_vector vector_up_closed vector_down_closed by blast

lemma vector_up_closed_down_closed:
  "vector x ⟷ up_closed x ∧ down_closed x"
  using down_closed_zero_vector up_closed_zero_vector_vector vector_up_closed vector_down_closed by blast

text ‹Section 7›

lemma vector_b1:
  "vector x ⟷ -x * top = -x"
  using complement_vector by auto

lemma vector_b2:
  "vector x ⟷ -x * bot = -x"
  by (metis down_closed_zero_vector vector_mult_closed zero_vector zero_vector_left_zero vector_b1 vector_down_closed)

lemma covector_b1:
  "co_vector x ⟷ -x * top = -x"
  using co_vector_def co_vector_vector vector_b1 vector_b2 by force

lemma covector_b2:
  "co_vector x ⟷ -x * bot = -x"
  using covector_b1 vector_b1 vector_b2 by auto

lemma vector_co_vector_iff:
  "vector x ⟷ co_vector x"
  by (simp add: covector_b2 vector_b2)

lemma zero_vector_b:
  "zero_vector x ⟷ -x * bot ≤ -x"
  by (simp add: complement_zero_vector_one_vector_iff one_vector_def)

lemma one_vector_b1:
  "one_vector x ⟷ -x ≤ -x * bot"
  by (simp add: complement_one_vector_zero_vector_iff zero_vector_def)

lemma one_vector_b0:
  "one_vector x ⟷ (∀y z . -x * y = -x * z)"
  by (simp add: complement_one_vector_zero_vector_iff zero_vector_0)

(*
lemma schroeder_one: "x * -1 ≤ y ⟷ -y * -1 ≤ -x" nitpick [expect=genuine,card=8] oops
*)

end

class multirelation_algebra_2b = multirelation_algebra_2 + complemented_distributive_lattice
begin

subclass multirelation_algebra_1b ..

(*
lemma "-x * bot ≤ -(x * bot)" nitpick [expect=genuine,card=8] oops
*)

end

text ‹complemented M1-algebra›

class multirelation_algebra_2c = multirelation_algebra_2b + multirelation_algebra_1c

class multirelation_algebra_3b = multirelation_algebra_3 + complemented_distributive_lattice
begin

subclass lattice_ordered_pre_left_semiring_b ..

lemma dual_complement_commute:
  "-(x⇧^d) = (-x)⇧^d"
  by (metis compl_unique dual_dist_sup dual_dist_inf dual_top dual_zero inf_complement sup_compl_top)

end

text ‹complemented M2-algebra›

class multirelation_algebra_5b = multirelation_algebra_5 + complemented_distributive_lattice
begin

subclass multirelation_algebra_2b ..

subclass multirelation_algebra_3b ..

lemma dual_down_closed:
  "down_closed x ⟷ down_closed (x⇧^d)"
  using complement_down_closed_up_closed dual_complement_commute dual_up_closed by auto

end

class multirelation_algebra_5c = multirelation_algebra_5b + multirelation_algebra_1c
begin

lemma complement_mult_zero_below:
  "-x * bot ≤ -(x * bot)"
  by (simp add: comp_zero_inf_2 shunting_1)

(*
lemma "x * 1 ⊓ y * 1 ≤ (x ⊓ y) * 1" nitpick [expect=genuine,card=4] oops
lemma "x * 1 ⊓ (y * 1) ≤ (x * 1 ⊓ y) * 1" nitpick [expect=genuine,card=4] oops
*)

end

class up_closed_multirelation_algebra_b = up_closed_multirelation_algebra + complemented_distributive_lattice
begin

subclass multirelation_algebra_5c
  apply unfold_locales
  apply (metis inf.sup_monoid.add_commute top_right_mult_increasing vector_inf_comp)
  using mult_right_dist_inf vector_zero_inf_comp by auto

lemma complement_zero_vector:
  "zero_vector x ⟷ zero_vector (-x)"
  by (simp add: zero_right_mult_decreasing zero_vector_b)

lemma down_closed:
  "down_closed x"
  by (simp add: down_closed_def)

lemma vector:
  "vector x"
  by (simp add: down_closed up_closed_def vector_up_closed_down_closed)

end

end

Theory Binary_Iterings

(* Title:      Binary Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Binary Iterings›

theory Binary_Iterings

imports Base

begin

class binary_itering = idempotent_left_zero_semiring + while +
  assumes while_productstar: "(x * y) ⋆ z = z ⊔ x * ((y * x) ⋆ (y * z))"
  assumes while_sumstar: "(x ⊔ y) ⋆ z = (x ⋆ y) ⋆ (x ⋆ z)"
  assumes while_left_dist_sup: "x ⋆ (y ⊔ z) = (x ⋆ y) ⊔ (x ⋆ z)"
  assumes while_sub_associative: "(x ⋆ y) * z ≤ x ⋆ (y * z)"
  assumes while_simulate_left_plus: "x * z ≤ z * (y ⋆ 1) ⊔ w ⟶ x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ (w * (y ⋆ v)))"
  assumes while_simulate_right_plus: "z * x ≤ y * (y ⋆ z) ⊔ w ⟶ z * (x ⋆ v) ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
begin

text ‹Theorem 9.1›

lemma while_zero:
  "bot ⋆ x = x"
  by (metis sup_bot_right mult_left_zero while_productstar)

text ‹Theorem 9.4›

lemma while_mult_increasing:
  "x * y ≤ x ⋆ y"
  by (metis le_supI2 mult.left_neutral mult_left_sub_dist_sup_left while_productstar)

text ‹Theorem 9.2›

lemma while_one_increasing:
  "x ≤ x ⋆ 1"
  by (metis mult.right_neutral while_mult_increasing)

text ‹Theorem 9.3›

lemma while_increasing:
  "y ≤ x ⋆ y"
  by (metis sup_left_divisibility mult_left_one while_productstar)

text ‹Theorem 9.42›

lemma while_right_isotone:
  "y ≤ z ⟹ x ⋆ y ≤ x ⋆ z"
  by (metis le_iff_sup while_left_dist_sup)

text ‹Theorem 9.41›

lemma while_left_isotone:
  "x ≤ y ⟹ x ⋆ z ≤ y ⋆ z"
  using sup_left_divisibility while_sumstar while_increasing by auto

lemma while_isotone:
  "w ≤ x ⟹ y ≤ z ⟹ w ⋆ y ≤ x ⋆ z"
  by (meson order_lesseq_imp while_left_isotone while_right_isotone)

text ‹Theorem 9.17›

lemma while_left_unfold:
  "x ⋆ y = y ⊔ x * (x ⋆ y)"
  by (metis mult_1_left mult_1_right while_productstar)

lemma while_simulate_left_plus_1:
  "x * z ≤ z * (y ⋆ 1) ⟹ x ⋆ (z * w) ≤ z * (y ⋆ w) ⊔ (x ⋆ bot)"
  by (metis sup_bot_right mult_left_zero while_simulate_left_plus)

text ‹Theorem 11.1›

lemma while_simulate_absorb:
  "y * x ≤ x ⟹ y ⋆ x ≤ x ⊔ (y ⋆ bot)"
  by (metis while_simulate_left_plus_1 while_zero mult_1_right)

text ‹Theorem 9.10›

lemma while_transitive:
  "x ⋆ (x ⋆ y) = x ⋆ y"
  by (metis order.eq_iff sup_bot_right sup_ge2 while_left_dist_sup while_increasing while_left_unfold while_simulate_absorb)

text ‹Theorem 9.25›

lemma while_slide:
  "(x * y) ⋆ (x * z) = x * ((y * x) ⋆ z)"
  by (metis mult_left_dist_sup while_productstar mult_assoc while_left_unfold)

text ‹Theorem 9.21›

lemma while_zero_2:
  "(x * bot) ⋆ y = x * bot ⊔ y"
  by (metis mult_left_zero sup_commute mult_assoc while_left_unfold)

text ‹Theorem 9.5›

lemma while_mult_star_exchange:
  "x * (x ⋆ y) = x ⋆ (x * y)"
  by (metis mult_left_one while_slide)

text ‹Theorem 9.18›

lemma while_right_unfold:
  "x ⋆ y = y ⊔ (x ⋆ (x * y))"
  by (metis while_left_unfold while_mult_star_exchange)

text ‹Theorem 9.7›

lemma while_one_mult_below:
  "(x ⋆ 1) * y ≤ x ⋆ y"
  by (metis mult_left_one while_sub_associative)

lemma while_plus_one:
  "x ⋆ y = y ⊔ (x ⋆ y)"
  by (simp add: sup.absorb2 while_increasing)

text ‹Theorem 9.19›

lemma while_rtc_2:
  "y ⊔ x * y ⊔ (x ⋆ (x ⋆ y)) = x ⋆ y"
  by (simp add: sup_absorb2 while_increasing while_mult_increasing while_transitive)

text ‹Theorem 9.6›

lemma while_left_plus_below:
  "x * (x ⋆ y) ≤ x ⋆ y"
  by (metis sup_right_divisibility while_left_unfold)

lemma while_right_plus_below:
  "x ⋆ (x * y) ≤ x ⋆ y"
  using while_left_plus_below while_mult_star_exchange by auto

lemma while_right_plus_below_2:
  "(x ⋆ x) * y ≤ x ⋆ y"
  by (smt order_trans while_right_plus_below while_sub_associative)

text ‹Theorem 9.47›

lemma while_mult_transitive:
  "x ≤ z ⋆ y ⟹ y ≤ z ⋆ w ⟹ x ≤ z ⋆ w"
  by (smt order_trans while_right_isotone while_transitive)

text ‹Theorem 9.48›

lemma while_mult_upper_bound:
  "x ≤ z ⋆ 1 ⟹ y ≤ z ⋆ w ⟹ x * y ≤ z ⋆ w"
  by (metis order.trans mult_isotone while_one_mult_below while_transitive)

lemma while_one_mult_while_below:
  "(y ⋆ 1) * (y ⋆ v) ≤ y ⋆ v"
  by (simp add: while_mult_upper_bound)

text ‹Theorem 9.34›

lemma while_sub_dist:
  "x ⋆ z ≤ (x ⊔ y) ⋆ z"
  by (simp add: while_left_isotone)

lemma while_sub_dist_1:
  "x * z ≤ (x ⊔ y) ⋆ z"
  using order.trans while_mult_increasing while_sub_dist by blast

lemma while_sub_dist_2:
  "x * y * z ≤ (x ⊔ y) ⋆ z"
  by (metis sup_commute mult_assoc while_mult_transitive while_sub_dist_1)

text ‹Theorem 9.36›

lemma while_sub_dist_3:
  "x ⋆ (y ⋆ z) ≤ (x ⊔ y) ⋆ z"
  by (metis sup_commute while_mult_transitive while_sub_dist)

text ‹Theorem 9.44›

lemma while_absorb_2:
  "x ≤ y ⟹ y ⋆ (x ⋆ z) = y ⋆ z"
  using sup_left_divisibility while_sumstar while_transitive by auto

lemma while_simulate_right_plus_1:
  "z * x ≤ y * (y ⋆ z) ⟹ z * (x ⋆ w) ≤ y ⋆ (z * w)"
  by (metis sup_bot_right mult_left_zero while_simulate_right_plus)

text ‹Theorem 9.39›

lemma while_sumstar_1_below:
  "x ⋆ ((y * (x ⋆ 1)) ⋆ z) ≤ ((x ⋆ 1) * y) ⋆ (x ⋆ z)"
proof -
  have 1: "x * (((x ⋆ 1) * y) ⋆ (x ⋆ z)) ≤ ((x ⋆ 1) * y) ⋆ (x ⋆ z)"
    by (smt sup_mono sup_ge2 mult_assoc mult_left_dist_sup mult_right_sub_dist_sup_right while_left_unfold)
  have "x ⋆ ((y * (x ⋆ 1)) ⋆ z) ≤ (x ⋆ z) ⊔ (x ⋆ (y * (((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z))))"
    by (metis eq_refl while_left_dist_sup while_productstar)
  also have "... ≤ (x ⋆ z) ⊔ (x ⋆ ((x ⋆ 1) * y * (((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z))))"
    by (metis sup_right_isotone mult_assoc mult_left_one mult_right_sub_dist_sup_left while_left_unfold while_right_isotone)
  also have "... ≤ (x ⋆ z) ⊔ (x ⋆ (((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z)))"
    using semiring.add_left_mono while_left_plus_below while_right_isotone by blast
  also have "... ≤ x ⋆ (((x ⋆ 1) * y) ⋆ (x ⋆ z))"
    by (meson order.trans le_supI while_increasing while_one_mult_below while_right_isotone)
  also have "... ≤ (((x ⋆ 1) * y) ⋆ (x ⋆ z)) ⊔ (x ⋆ bot)"
    using 1 while_simulate_absorb by auto
  also have "... = ((x ⋆ 1) * y) ⋆ (x ⋆ z)"
    by (smt sup_assoc sup_commute sup_bot_left while_left_dist_sup while_left_unfold)
  finally show ?thesis
    .
qed

lemma while_sumstar_2_below:
  "((x ⋆ 1) * y) ⋆ (x ⋆ z) ≤ (x ⋆ y) ⋆ (x ⋆ z)"
  by (simp add: while_left_isotone while_one_mult_below)

text ‹Theorem 9.38›

lemma while_sup_1_below:
  "x ⋆ ((y * (x ⋆ 1)) ⋆ z) ≤ (x ⊔ y) ⋆ z"
proof -
  have "((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z) ≤ (x ⊔ y) ⋆ z"
    using while_sumstar while_isotone while_one_mult_below by auto
  hence "(y * (x ⋆ 1)) ⋆ z ≤ z ⊔ y * ((x ⊔ y) ⋆ z)"
    by (metis sup_right_isotone mult_right_isotone while_productstar)
  also have "... ≤ (x ⊔ y) ⋆ z"
    by (metis sup_right_isotone sup_ge2 mult_left_isotone while_left_unfold)
  finally show ?thesis
    using while_mult_transitive while_sub_dist by blast
qed

text ‹Theorem 9.16›

lemma while_while_while:
  "((x ⋆ 1) ⋆ 1) ⋆ y = (x ⋆ 1) ⋆ y"
  by (smt (z3) sup.absorb1 while_sumstar while_absorb_2 while_increasing while_one_increasing)

lemma while_one:
  "(1 ⋆ 1) ⋆ y = 1 ⋆ y"
  by (metis while_while_while while_zero)

text ‹Theorem 9.22›

lemma while_sup_below:
  "x ⊔ y ≤ x ⋆ (y ⋆ 1)"
  by (metis le_supI le_supI1 while_left_dist_sup while_left_unfold while_one_increasing)

text ‹Theorem 9.32›

lemma while_sup_2:
  "(x ⊔ y) ⋆ z ≤ (x ⋆ (y ⋆ 1)) ⋆ z"
  using while_left_isotone while_sup_below by auto

text ‹Theorem 9.45›

lemma while_sup_one_left_unfold:
  "1 ≤ x ⟹ x * (x ⋆ y) = x ⋆ y"
  by (metis order.antisym mult_1_left mult_left_isotone while_left_plus_below)

lemma while_sup_one_right_unfold:
  "1 ≤ x ⟹ x ⋆ (x * y) = x ⋆ y"
  using while_mult_star_exchange while_sup_one_left_unfold by auto

text ‹Theorem 9.30›

lemma while_decompose_7:
  "(x ⊔ y) ⋆ z = x ⋆ (y ⋆ ((x ⊔ y) ⋆ z))"
  by (metis order.eq_iff order_trans while_increasing while_sub_dist_3 while_transitive)

text ‹Theorem 9.31›

lemma while_decompose_8:
  "(x ⊔ y) ⋆ z = (x ⊔ y) ⋆ (x ⋆ (y ⋆ z))"
  using while_absorb_2 by auto

text ‹Theorem 9.27›

lemma while_decompose_9:
  "(x ⋆ (y ⋆ 1)) ⋆ z = x ⋆ (y ⋆ ((x ⋆ (y ⋆ 1)) ⋆ z))"
  by (smt sup_commute le_iff_sup order_trans while_sup_below while_increasing while_sub_dist_3)

lemma while_decompose_10:
  "(x ⋆ (y ⋆ 1)) ⋆ z = (x ⋆ (y ⋆ 1)) ⋆ (x ⋆ (y ⋆ z))"
proof -
  have 1: "(x ⋆ (y ⋆ 1)) ⋆ z ≤ (x ⋆ (y ⋆ 1)) ⋆ (x ⋆ (y ⋆ z))"
    by (meson order.trans while_increasing while_right_isotone)
  have "x ⊔ (y ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
    using while_increasing while_sup_below by auto
  hence "(x ⋆ (y ⋆ 1)) ⋆ (x ⋆ (y ⋆ z)) ≤ (x ⋆ (y ⋆ 1)) ⋆ z"
    using while_absorb_2 while_sup_below by force
  thus ?thesis
    using 1 order.antisym by blast
qed

lemma while_back_loop_fixpoint:
  "z * (y ⋆ (y * x)) ⊔ z * x = z * (y ⋆ x)"
  by (metis sup_commute mult_left_dist_sup while_right_unfold)

lemma while_back_loop_prefixpoint:
  "z * (y ⋆ 1) * y ⊔ z ≤ z * (y ⋆ 1)"
  by (metis le_supI le_supI2 mult_1_right mult_right_isotone mult_assoc while_increasing while_one_mult_below while_right_unfold)

text ‹Theorem 9›

lemma while_loop_is_fixpoint:
  "is_fixpoint (λx . y * x ⊔ z) (y ⋆ z)"
  using is_fixpoint_def sup_commute while_left_unfold by auto

text ‹Theorem 9›

lemma while_back_loop_is_prefixpoint:
  "is_prefixpoint (λx . x * y ⊔ z) (z * (y ⋆ 1))"
  using is_prefixpoint_def while_back_loop_prefixpoint by auto

text ‹Theorem 9.20›

lemma while_while_sup:
  "(1 ⊔ x) ⋆ y = (x ⋆ 1) ⋆ y"
  by (metis sup_commute while_decompose_10 while_sumstar while_zero)

lemma while_while_mult_sub:
  "x ⋆ (1 ⋆ y) ≤ (x ⋆ 1) ⋆ y"
  by (metis sup_commute while_sub_dist_3 while_while_sup)

text ‹Theorem 9.11›

lemma while_right_plus:
  "(x ⋆ x) ⋆ y = x ⋆ y"
  by (metis sup_idem while_plus_one while_sumstar while_transitive)

text ‹Theorem 9.12›

lemma while_left_plus:
  "(x * (x ⋆ 1)) ⋆ y = x ⋆ y"
  by (simp add: while_mult_star_exchange while_right_plus)

text ‹Theorem 9.9›

lemma while_below_while_one:
  "x ⋆ x ≤ x ⋆ 1"
  by (meson eq_refl while_mult_transitive while_one_increasing)

lemma while_below_while_one_mult:
  "x * (x ⋆ x) ≤ x * (x ⋆ 1)"
  by (simp add: mult_right_isotone while_below_while_one)

text ‹Theorem 9.23›

lemma while_sup_sub_sup_one:
  "x ⋆ (x ⊔ y) ≤ x ⋆ (1 ⊔ y)"
  using semiring.add_right_mono while_left_dist_sup while_below_while_one by auto

lemma while_sup_sub_sup_one_mult:
  "x * (x ⋆ (x ⊔ y)) ≤ x * (x ⋆ (1 ⊔ y))"
  by (simp add: mult_right_isotone while_sup_sub_sup_one)

lemma while_elimination:
  "x * y = bot ⟹ x * (y ⋆ z) = x * z"
  by (metis sup_bot_right mult_assoc mult_left_dist_sup mult_left_zero while_left_unfold)

text ‹Theorem 9.8›

lemma while_square:
  "(x * x) ⋆ y ≤ x ⋆ y"
  by (metis while_left_isotone while_mult_increasing while_right_plus)

text ‹Theorem 9.35›

lemma while_mult_sub_sup:
  "(x * y) ⋆ z ≤ (x ⊔ y) ⋆ z"
  by (metis while_increasing while_isotone while_mult_increasing while_sumstar)

text ‹Theorem 9.43›

lemma while_absorb_1:
  "x ≤ y ⟹ x ⋆ (y ⋆ z) = y ⋆ z"
  by (metis order.antisym le_iff_sup while_increasing while_sub_dist_3)

lemma while_absorb_3:
  "x ≤ y ⟹ x ⋆ (y ⋆ z) = y ⋆ (x ⋆ z)"
  by (simp add: while_absorb_1 while_absorb_2)

text ‹Theorem 9.24›

lemma while_square_2:
  "(x * x) ⋆ ((x ⊔ 1) * y) ≤ x ⋆ y"
  by (metis le_supI while_increasing while_mult_transitive while_mult_upper_bound while_one_increasing while_square)

lemma while_separate_unfold_below:
  "(y * (x ⋆ 1)) ⋆ z ≤ (y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ ((y * (x ⋆ 1)) ⋆ z))))"
proof -
  have "(y * (x ⋆ 1)) ⋆ z = (y ⋆ (y * x * (x ⋆ 1))) ⋆ (y ⋆ z)"
    by (metis mult_assoc mult_left_dist_sup mult_1_right while_left_unfold while_sumstar)
  hence "(y * (x ⋆ 1)) ⋆ z = (y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ 1))) * ((y * (x ⋆ 1)) ⋆ z)"
    using while_left_unfold by auto
  also have "... ≤ (y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ 1)) * ((y * (x ⋆ 1)) ⋆ z))"
    using sup_right_isotone while_sub_associative by auto
  also have "... ≤ (y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ ((y * (x ⋆ 1)) ⋆ z))))"
    by (smt sup_right_isotone mult_assoc mult_right_isotone while_one_mult_below while_right_isotone)
  finally show ?thesis
    .
qed

text ‹Theorem 9.33›

lemma while_mult_zero_sup:
  "(x ⊔ y * bot) ⋆ z = x ⋆ ((y * bot) ⋆ z)"
proof -
  have "(x ⊔ y * bot) ⋆ z = (x ⋆ (y * bot)) ⋆ (x ⋆ z)"
    by (simp add: while_sumstar)
  also have "... = (x ⋆ z) ⊔ (x ⋆ (y * bot)) * ((x ⋆ (y * bot)) ⋆ (x ⋆ z))"
    using while_left_unfold by auto
  also have "... ≤ (x ⋆ z) ⊔ (x ⋆ (y * bot))"
    by (metis sup_right_isotone mult_assoc mult_left_zero while_sub_associative)
  also have "... = x ⋆ ((y * bot) ⋆ z)"
    by (simp add: sup_commute while_left_dist_sup while_zero_2)
  finally show ?thesis
    by (simp add: order.antisym while_sub_dist_3)
qed

lemma while_sup_mult_zero:
  "(x ⊔ y * bot) ⋆ y = x ⋆ y"
  by (simp add: sup_absorb2 zero_right_mult_decreasing while_mult_zero_sup while_zero_2)

lemma while_mult_zero_sup_2:
  "(x ⊔ y * bot) ⋆ z = (x ⋆ z) ⊔ (x ⋆ (y * bot))"
  by (simp add: sup_commute while_left_dist_sup while_mult_zero_sup while_zero_2)

lemma while_sup_zero_star:
  "(x ⊔ y * bot) ⋆ z = x ⋆ (y * bot ⊔ z)"
  by (simp add: while_mult_zero_sup while_zero_2)

lemma while_unfold_sum:
  "(x ⊔ y) ⋆ z = (x ⋆ z) ⊔ (x ⋆ (y * ((x ⊔ y) ⋆ z)))"
  apply (rule order.antisym)
  apply (metis semiring.add_left_mono while_sub_associative while_sumstar while_left_unfold)
  by (metis le_supI while_decompose_7 while_mult_increasing while_right_isotone while_sub_dist)

lemma while_simulate_left:
  "x * z ≤ z * y ⊔ w ⟹ x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ (w * (y ⋆ v)))"
  by (metis sup_left_isotone mult_right_isotone order_trans while_one_increasing while_simulate_left_plus)

lemma while_simulate_right:
  assumes "z * x ≤ y * z ⊔ w"
    shows "z * (x ⋆ v) ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
proof -
  have "y * z ⊔ w ≤ y * (y ⋆ z) ⊔ w"
    using sup_left_isotone while_increasing while_mult_star_exchange by force
  thus ?thesis
    by (meson assms order.trans while_simulate_right_plus)
qed

lemma while_simulate:
  "z * x ≤ y * z ⟹ z * (x ⋆ v) ≤ y ⋆ (z * v)"
  by (metis sup_bot_right mult_left_zero while_simulate_right)

text ‹Theorem 9.14›

lemma while_while_mult:
  "1 ⋆ (x ⋆ y) = (x ⋆ 1) ⋆ y"
proof -
  have "(x ⋆ 1) ⋆ y ≤ (x ⋆ 1) * ((x ⋆ 1) ⋆ y)"
    by (simp add: while_increasing while_sup_one_left_unfold)
  also have "... ≤ 1 ⋆ ((x ⋆ 1) * y)"
    by (simp add: while_one_mult_while_below while_simulate)
  also have "... ≤ 1 ⋆ (x ⋆ y)"
    by (simp add: while_isotone while_one_mult_below)
  finally show ?thesis
    by (metis order.antisym while_sub_dist_3 while_while_sup)
qed

lemma while_simulate_left_1:
  "x * z ≤ z * y ⟹ x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ bot)"
  by (meson order.trans mult_right_isotone while_one_increasing while_simulate_left_plus_1)

text ‹Theorem 9.46›

lemma while_associative_1:
  assumes "1 ≤ z"
  shows "x ⋆ (y * z) = (x ⋆ y) * z"
proof -
  have "x ⋆ (y * z) ≤ x ⋆ ((x ⋆ y) * z)"
    by (simp add: mult_isotone while_increasing while_right_isotone)
  also have "... ≤ (x ⋆ y) * (bot ⋆ z) ⊔ (x ⋆ bot)"
    by (metis mult_assoc mult_right_sub_dist_sup_right while_left_unfold while_simulate_absorb while_zero)
  also have "... ≤ (x ⋆ y) * z ⊔ (x ⋆ bot) * z"
    by (metis assms le_supI sup_ge1 sup_ge2 case_split_right while_plus_one while_zero)
  also have "... = (x ⋆ y) * z"
    by (metis sup_bot_right mult_right_dist_sup while_left_dist_sup)
  finally show ?thesis
    by (simp add: order.antisym while_sub_associative)
qed

text ‹Theorem 9.29›

lemma while_associative_while_1:
  "x ⋆ (y * (z ⋆ 1)) = (x ⋆ y) * (z ⋆ 1)"
  by (simp add: while_associative_1 while_increasing)

text ‹Theorem 9.13›

lemma while_one_while:
  "(x ⋆ 1) * (y ⋆ 1) = x ⋆ (y ⋆ 1)"
  by (metis mult_left_one while_associative_while_1)

lemma while_decompose_5_below:
  "(x ⋆ (y ⋆ 1)) ⋆ z ≤ (y ⋆ (x ⋆ 1)) ⋆ z"
  by (smt (z3) while_left_dist_sup while_sumstar while_absorb_2 while_one_increasing while_plus_one while_sub_dist)

text ‹Theorem 9.26›

lemma while_decompose_5:
  "(x ⋆ (y ⋆ 1)) ⋆ z = (y ⋆ (x ⋆ 1)) ⋆ z"
  by (simp add: order.antisym while_decompose_5_below)

lemma while_decompose_4:
  "(x ⋆ (y ⋆ 1)) ⋆ z = x ⋆ ((y ⋆ (x ⋆ 1)) ⋆ z)"
  using while_absorb_1 while_decompose_5 while_sup_below by auto

text ‹Theorem 11.7›

lemma while_simulate_2:
  "y * (x ⋆ 1) ≤ x ⋆ (y ⋆ 1) ⟷ y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
proof
  assume "y * (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
  hence "y * (x ⋆ 1) ≤ (x ⋆ 1) * (y ⋆ 1)"
    by (simp add: while_one_while)
  hence "y ⋆ ((x ⋆ 1) * 1) ≤ (x ⋆ 1) * (y ⋆ 1) ⊔ (y ⋆ bot)"
    using while_simulate_left_plus_1 by blast
  hence "y ⋆ (x ⋆ 1) ≤ (x ⋆ (y ⋆ 1)) ⊔ (y ⋆ bot)"
    by (simp add: while_one_while)
  also have "... = x ⋆ (y ⋆ 1)"
    by (metis sup_commute le_iff_sup order_trans while_increasing while_right_isotone bot_least)
  finally show "y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
    .
next
  assume "y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
  thus "y * (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
    using order_trans while_mult_increasing by blast
qed

lemma while_simulate_1:
  "y * x ≤ x * y ⟹ y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
  by (metis order_trans while_mult_increasing while_right_isotone while_simulate while_simulate_2)

lemma while_simulate_3:
  "y * (x ⋆ 1) ≤ x ⋆ 1 ⟹ y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1)"
  by (meson order.trans while_increasing while_right_isotone while_simulate_2)

text ‹Theorem 9.28›

lemma while_extra_while:
  "(y * (x ⋆ 1)) ⋆ z = (y * (y ⋆ (x ⋆ 1))) ⋆ z"
proof -
  have "y * (y ⋆ (x ⋆ 1)) ≤ y * (x ⋆ 1) * (y * (x ⋆ 1) ⋆ 1)"
    using while_back_loop_prefixpoint while_left_isotone while_mult_star_exchange by auto
  hence 1: "(y * (y ⋆ (x ⋆ 1))) ⋆ z ≤ (y * (x ⋆ 1)) ⋆ z"
    by (metis while_simulate_right_plus_1 mult_left_one)
  have "(y * (x ⋆ 1)) ⋆ z ≤ (y * (y ⋆ (x ⋆ 1))) ⋆ z"
    by (simp add: while_increasing while_left_isotone while_mult_star_exchange)
  thus ?thesis
    using 1 order.antisym by auto
qed

text ‹Theorem 11.6›

lemma while_separate_4:
  assumes "y * x ≤ x * (x ⋆ (1 ⊔ y))"
    shows "(x ⊔ y) ⋆ z = x ⋆ (y ⋆ z)"
proof -
  have "(1 ⊔ y) * x ≤ x * (x ⋆ (1 ⊔ y))"
    by (smt assms sup_assoc le_supI mult_left_one mult_left_sub_dist_sup_left mult_right_dist_sup mult_1_right while_left_unfold)
  hence 1: "(1 ⊔ y) * (x ⋆ 1) ≤ x ⋆ (1 ⊔ y)"
    by (metis mult_1_right while_simulate_right_plus_1)
  have "y * x * (x ⋆ 1) ≤ x * (x ⋆ ((1 ⊔ y) * (x ⋆ 1)))"
    by (smt assms le_iff_sup mult_assoc mult_right_dist_sup while_associative_1 while_increasing)
  also have "... ≤ x * (x ⋆ (1 ⊔ y))"
    using 1 mult_right_isotone while_mult_transitive by blast
  also have "... ≤ x * (x ⋆ 1) * (y ⋆ 1)"
    by (simp add: mult_right_isotone mult_assoc while_increasing while_one_increasing while_one_while while_right_isotone)
  finally have "y ⋆ (x * (x ⋆ 1)) ≤ x * (x ⋆ 1) * (y ⋆ 1) ⊔ (y ⋆ bot)"
    by (metis mult_assoc mult_1_right while_simulate_left_plus_1)
  hence "(y ⋆ 1) * (y ⋆ x) ≤ x * (x ⋆ y ⋆ 1) ⊔ (y ⋆ bot)"
    by (smt le_iff_sup mult_assoc mult_1_right order_refl order_trans while_absorb_2 while_left_dist_sup while_mult_star_exchange while_one_mult_below while_one_while while_plus_one)
  hence "(y ⋆ 1) * ((y ⋆ x) ⋆ (y ⋆ z)) ≤ x ⋆ ((y ⋆ 1) * (y ⋆ z) ⊔ (y ⋆ bot) * ((y ⋆ x) ⋆ (y ⋆ z)))"
    by (simp add: while_simulate_right_plus)
  also have "... ≤ x ⋆ ((y ⋆ z) ⊔ (y ⋆ bot))"
    by (metis sup_mono mult_left_zero order_refl while_absorb_2 while_one_mult_below while_right_isotone while_sub_associative)
  also have "... = x ⋆ y ⋆ z"
    using sup.absorb_iff1 while_right_isotone by auto
  finally show ?thesis
    by (smt sup_commute le_iff_sup mult_left_one mult_right_dist_sup while_plus_one while_sub_associative while_sumstar)
qed

lemma while_separate_5:
  "y * x ≤ x * (x ⋆ (x ⊔ y)) ⟹ (x ⊔ y) ⋆ z = x ⋆ (y ⋆ z)"
  using order_lesseq_imp while_separate_4 while_sup_sub_sup_one_mult by blast

lemma while_separate_6:
  "y * x ≤ x * (x ⊔ y) ⟹ (x ⊔ y) ⋆ z = x ⋆ (y ⋆ z)"
  by (smt order_trans while_increasing while_mult_star_exchange while_separate_5)

text ‹Theorem 11.4›

lemma while_separate_1:
  "y * x ≤ x * y ⟹ (x ⊔ y) ⋆ z = x ⋆ (y ⋆ z)"
  using mult_left_sub_dist_sup_right order_lesseq_imp while_separate_6 by blast

text ‹Theorem 11.2›

lemma while_separate_mult_1:
  "y * x ≤ x * y ⟹ (x * y) ⋆ z ≤ x ⋆ (y ⋆ z)"
  by (metis while_mult_sub_sup while_separate_1)

text ‹Theorem 11.5›

lemma separation:
  assumes "y * x ≤ x * (y ⋆ 1)"
    shows "(x ⊔ y) ⋆ z = x ⋆ (y ⋆ z)"
proof -
  have "y ⋆ x ≤ x * (y ⋆ 1) ⊔ (y ⋆ bot)"
    by (metis assms mult_1_right while_simulate_left_plus_1)
  also have "... ≤ x * (x ⋆ y ⋆ 1) ⊔ (y ⋆ bot)"
    using sup_left_isotone while_increasing while_mult_star_exchange by force
  finally have "(y ⋆ 1) * (y ⋆ x) ≤ x * (x ⋆ y ⋆ 1) ⊔ (y ⋆ bot)"
    using order.trans while_one_mult_while_below by blast
  hence "(y ⋆ 1) * ((y ⋆ x) ⋆ (y ⋆ z)) ≤ x ⋆ ((y ⋆ 1) * (y ⋆ z) ⊔ (y ⋆ bot) * ((y ⋆ x) ⋆ (y ⋆ z)))"
    by (simp add: while_simulate_right_plus)
  also have "... ≤ x ⋆ ((y ⋆ z) ⊔ (y ⋆ bot))"
    by (metis sup_mono mult_left_zero order_refl while_absorb_2 while_one_mult_below while_right_isotone while_sub_associative)
  also have "... = x ⋆ y ⋆ z"
    using sup.absorb_iff1 while_right_isotone by auto
  finally show ?thesis
    by (smt sup_commute le_iff_sup mult_left_one mult_right_dist_sup while_plus_one while_sub_associative while_sumstar)
qed

text ‹Theorem 11.5›

lemma while_separate_left:
  "y * x ≤ x * (y ⋆ 1) ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)"
  by (metis sup_commute separation while_sub_dist_3)

text ‹Theorem 11.6›

lemma while_simulate_4:
  "y * x ≤ x * (x ⋆ (1 ⊔ y)) ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)"
  by (metis sup_commute while_separate_4 while_sub_dist_3)

lemma while_simulate_5:
  "y * x ≤ x * (x ⋆ (x ⊔ y)) ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)"
  by (smt order_trans while_sup_sub_sup_one_mult while_simulate_4)

lemma while_simulate_6:
  "y * x ≤ x * (x ⊔ y) ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)"
  by (smt order_trans while_increasing while_mult_star_exchange while_simulate_5)

text ‹Theorem 11.3›

lemma while_simulate_7:
  "y * x ≤ x * y ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)"
  using mult_left_sub_dist_sup_right order_lesseq_imp while_simulate_6 by blast

lemma while_while_mult_1:
  "x ⋆ (1 ⋆ y) = 1 ⋆ (x ⋆ y)"
  by (metis sup_commute mult_left_one mult_1_right order_refl while_separate_1)

text ‹Theorem 9.15›

lemma while_while_mult_2:
  "x ⋆ (1 ⋆ y) = (x ⋆ 1) ⋆ y"
  by (simp add: while_while_mult while_while_mult_1)

text ‹Theorem 11.8›

lemma while_import:
  assumes "p ≤ p * p ∧ p ≤ 1 ∧ p * x ≤ x * p"
    shows "p * (x ⋆ y) = p * ((p * x) ⋆ y)"
proof -
  have "p * (x ⋆ y) ≤ (p * x) ⋆ (p * y)"
    using assms test_preserves_equation while_simulate by auto
  also have "... ≤ (p * x) ⋆ y"
    by (metis assms le_iff_sup mult_left_one mult_right_dist_sup while_right_isotone)
  finally have 2: "p * (x ⋆ y) ≤ p * ((p * x) ⋆ y)"
    by (smt assms sup_commute le_iff_sup mult_assoc mult_left_dist_sup mult_1_right)
  have "p * ((p * x) ⋆ y) ≤ p * (x ⋆ y)"
    by (metis assms mult_left_isotone mult_left_one mult_right_isotone while_left_isotone)
  thus ?thesis
    using 2 order.antisym by auto
qed

text ‹Theorem 11.8›

lemma while_preserve:
  assumes "p ≤ p * p"
      and "p ≤ 1"
      and "p * x ≤ x * p"
    shows "p * (x ⋆ y) = p * (x ⋆ (p * y))"
proof (rule order.antisym)
  show "p * (x ⋆ y) ≤ p * (x ⋆ (p * y))"
    by (metis assms order.antisym coreflexive_transitive mult_right_isotone mult_assoc while_simulate)
  show "p * (x ⋆ (p * y)) ≤ p * (x ⋆ y)"
    by (metis assms(2) mult_left_isotone mult_left_one mult_right_isotone while_right_isotone)
qed

lemma while_plus_below_while:
  "(x ⋆ 1) * x ≤ x ⋆ 1"
  by (simp add: while_mult_upper_bound while_one_increasing)

text ‹Theorem 9.40›

lemma while_01:
  "(w * (x ⋆ 1)) ⋆ (y * z) ≤ (x ⋆ w) ⋆ ((x ⋆ y) * z)"
proof -
  have "(w * (x ⋆ 1)) ⋆ (y * z) = y * z ⊔ w * (((x ⋆ 1) * w) ⋆ ((x ⋆ 1) * y * z))"
    by (metis mult_assoc while_productstar)
  also have "... ≤ y * z ⊔ w * ((x ⋆ w) ⋆ ((x ⋆ y) * z))"
    by (metis sup_right_isotone mult_left_isotone mult_right_isotone while_isotone while_one_mult_below)
  also have "... ≤ (x ⋆ y) * z ⊔ (x ⋆ w) * ((x ⋆ w) ⋆ ((x ⋆ y) * z))"
    by (meson mult_left_isotone semiring.add_mono while_increasing)
  finally show ?thesis
    using while_left_unfold by auto
qed

text ‹Theorem 9.37›

lemma while_while_sub_associative:
  "x ⋆ (y ⋆ z) ≤ ((x ⋆ y) ⋆ z) ⊔ (x ⋆ z)"
proof -
  have 1: "x * (x ⋆ 1) ≤ (x ⋆ 1) * ((x ⋆ y) ⋆ 1)"
    by (metis le_supE while_back_loop_prefixpoint while_mult_increasing while_mult_transitive while_one_while)
  have "x ⋆ (y ⋆ z) ≤ x ⋆ ((x ⋆ 1) * (y ⋆ z))"
    by (metis mult_left_isotone mult_left_one while_increasing while_right_isotone)
  also have "... ≤ (x ⋆ 1) * ((x ⋆ y) ⋆ (y ⋆ z)) ⊔ (x ⋆ bot)"
    using 1 while_simulate_left_plus_1 by auto
  also have "... ≤ (x ⋆ 1) * ((x ⋆ y) ⋆ z) ⊔ (x ⋆ z)"
    by (simp add: le_supI1 sup_commute while_absorb_2 while_increasing while_right_isotone)
  also have "... = (x ⋆ 1) * z ⊔ (x ⋆ 1) * (x ⋆ y) * ((x ⋆ y) ⋆ z) ⊔ (x ⋆ z)"
    by (metis mult_assoc mult_left_dist_sup while_left_unfold)
  also have "... = (x ⋆ y) * ((x ⋆ y) ⋆ z) ⊔ (x ⋆ z)"
    by (smt sup_assoc sup_commute le_iff_sup mult_left_one mult_right_dist_sup order_refl while_absorb_1 while_plus_one while_sub_associative)
  also have "... ≤ ((x ⋆ y) ⋆ z) ⊔ (x ⋆ z)"
    using sup_left_isotone while_left_plus_below by auto
  finally show ?thesis
    .
qed

lemma while_induct:
  "x * z ≤ z ∧ y ≤ z ∧ x ⋆ 1 ≤ z ⟹ x ⋆ y ≤ z"
  by (metis le_supI1 sup_commute sup_bot_left le_iff_sup while_right_isotone while_simulate_absorb)

(*
lemma while_sumstar_4_below: "(x ⋆ y) ⋆ ((x ⋆ 1) * z) ≤ x ⋆ ((y * (x ⋆ 1)) ⋆ z)" oops
lemma while_sumstar_2: "(x ⊔ y) ⋆ z = x ⋆ ((y * (x ⋆ 1)) ⋆ z)" oops
lemma while_sumstar_3: "(x ⊔ y) ⋆ z = ((x ⋆ 1) * y) ⋆ (x ⋆ z)" oops
lemma while_decompose_6: "x ⋆ ((y * (x ⋆ 1)) ⋆ z) = y ⋆ ((x * (y ⋆ 1)) ⋆ z)" oops
lemma while_finite_associative: "x ⋆ bot = bot ⟹ (x ⋆ y) * z = x ⋆ (y * z)" oops
lemma atomicity_refinement: "s = s * q ⟹ x = q * x ⟹ q * b = bot ⟹ r * b ≤ b * r ⟹ r * l ≤ l * r ⟹ x * l ≤ l * x ⟹ b * l ≤ l * b ⟹ q * l ≤ l * q ⟹ r ⋆ q ≤ q * (r ⋆ 1) ⟹ q ≤ 1 ⟹ s * ((x ⊔ b ⊔ r ⊔ l) ⋆ (q * z)) ≤ s * ((x * (b ⋆ q) ⊔ r ⊔ l) ⋆ z)" oops

lemma while_separate_right_plus: "y * x ≤ x * (x ⋆ (1 ⊔ y)) ⊔ 1 ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)" oops
lemma while_square_1: "x ⋆ 1 = (x * x) ⋆ (x ⊔ 1)" oops
lemma while_absorb_below_one: "y * x ≤ x ⟹ y ⋆ x ≤ 1 ⋆ x" oops
lemma "y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
lemma "y * x ≤ (1 ⊔ x) * (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
*)

end

class bounded_binary_itering = bounded_idempotent_left_zero_semiring + binary_itering
begin

text ‹Theorem 9›

lemma while_right_top:
  "x ⋆ top = top"
  by (metis sup_left_top while_left_unfold)

text ‹Theorem 9›

lemma while_left_top:
  "top * (x ⋆ 1) = top"
  by (meson order.antisym le_supE top_greatest while_back_loop_prefixpoint)

end

class extended_binary_itering = binary_itering +
  assumes while_denest_0: "w * (x ⋆ (y * z)) ≤ (w * (x ⋆ y)) ⋆ (w * (x ⋆ y) * z)"
begin

text ‹Theorem 10.2›

lemma while_denest_1:
  "w * (x ⋆ (y * z)) ≤ (w * (x ⋆ y)) ⋆ z"
  using while_denest_0 while_mult_increasing while_mult_transitive by blast

lemma while_mult_sub_while_while:
  "x ⋆ (y * z) ≤ (x ⋆ y) ⋆ z"
  by (metis mult_left_one while_denest_1)

lemma while_zero_zero:
  "(x ⋆ bot) ⋆ bot = x ⋆ bot"
  by (metis order.antisym mult_left_zero sup_bot_left while_left_unfold while_sub_associative while_mult_sub_while_while)

text ‹Theorem 10.11›

lemma while_mult_zero_zero:
  "(x * (y ⋆ bot)) ⋆ bot = x * (y ⋆ bot)"
  apply (rule order.antisym)
  apply (metis sup_bot_left while_left_unfold mult_assoc le_supI1 mult_left_zero mult_right_isotone while_left_dist_sup while_sub_associative)
  by (metis mult_left_zero while_denest_1)

text ‹Theorem 10.3›

lemma while_denest_2:
  "w * ((x ⋆ (y * w)) ⋆ z) = w * (((x ⋆ y) * w) ⋆ z)"
  apply (rule order.antisym)
  apply (metis mult_assoc while_denest_0 while_simulate_right_plus_1 while_slide)
  by (simp add: mult_isotone while_left_isotone while_sub_associative)

text ‹Theorem 10.12›

lemma while_denest_3:
  "(x ⋆ w) ⋆ (x ⋆ bot) = (x ⋆ w) ⋆ bot"
  by (metis while_absorb_2 while_right_isotone while_zero_zero bot_least)

text ‹Theorem 10.15›

lemma while_02:
  "x ⋆ ((x ⋆ w) ⋆ ((x ⋆ y) * z)) = (x ⋆ w) ⋆ ((x ⋆ y) * z)"
proof -
  have "x * ((x ⋆ w) ⋆ ((x ⋆ y) * z)) = x * (x ⋆ y) * z ⊔ x * (x ⋆ w) * ((x ⋆ w) ⋆ ((x ⋆ y) * z))"
    by (metis mult_assoc mult_left_dist_sup while_left_unfold)
  also have "... ≤ (x ⋆ w) ⋆ ((x ⋆ y) * z)"
    by (metis sup_mono mult_right_sub_dist_sup_right while_left_unfold)
  finally have "x ⋆ ((x ⋆ w) ⋆ ((x ⋆ y) * z)) ≤ ((x ⋆ w) ⋆ ((x ⋆ y) * z)) ⊔ (x ⋆ bot)"
    using while_simulate_absorb by auto
  also have "... = (x ⋆ w) ⋆ ((x ⋆ y) * z)"
    by (metis sup_commute le_iff_sup order_trans while_mult_sub_while_while while_right_isotone bot_least)
  finally show ?thesis
    by (simp add: order.antisym while_increasing)
qed

lemma while_sumstar_3_below:
  "(x ⋆ y) ⋆ (x ⋆ z) ≤ (x ⋆ y) ⋆ ((x ⋆ 1) * z)"
proof -
  have "(x ⋆ y) ⋆ (x ⋆ z) = (x ⋆ z) ⊔ ((x ⋆ y) ⋆ ((x ⋆ y) * (x ⋆ z)))"
    using while_right_unfold by blast
  also have "... ≤ (x ⋆ z) ⊔ ((x ⋆ y) ⋆ (x ⋆ (y * (x ⋆ z))))"
    by (meson sup_right_isotone while_right_isotone while_sub_associative)
  also have "... ≤ (x ⋆ z) ⊔ ((x ⋆ y) ⋆ (x ⋆ ((x ⋆ y) ⋆ (x ⋆ z))))"
    by (smt sup_right_isotone order_trans while_increasing while_mult_upper_bound while_one_increasing while_right_isotone)
  also have "... ≤ (x ⋆ z) ⊔ ((x ⋆ y) ⋆ (x ⋆ ((x ⋆ y) ⋆ ((x ⋆ 1) * z))))"
    by (metis sup_right_isotone mult_left_isotone mult_left_one order_trans while_increasing while_right_isotone while_sumstar while_transitive)
  also have "... = (x ⋆ z) ⊔ ((x ⋆ y) ⋆ ((x ⋆ 1) * z))"
    by (simp add: while_transitive while_02)
  also have "... = (x ⋆ y) ⋆ ((x ⋆ 1) * z)"
    by (smt sup_assoc mult_left_one mult_right_dist_sup while_02 while_left_dist_sup while_plus_one)
  finally show ?thesis
    .
qed

lemma while_sumstar_4_below:
  "(x ⋆ y) ⋆ ((x ⋆ 1) * z) ≤ x ⋆ ((y * (x ⋆ 1)) ⋆ z)"
proof -
  have "(x ⋆ y) ⋆ ((x ⋆ 1) * z) = (x ⋆ 1) * z ⊔ (x ⋆ y) * ((x ⋆ y) ⋆ ((x ⋆ 1) * z))"
    using while_left_unfold by auto
  also have "... ≤ (x ⋆ z) ⊔ (x ⋆ (y * ((x ⋆ y) ⋆ ((x ⋆ 1) * z))))"
    by (meson sup_mono while_one_mult_below while_sub_associative)
  also have "... = (x ⋆ z) ⊔ (x ⋆ (y * (((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z))))"
    by (metis mult_left_one while_denest_2)
  also have "... = x ⋆ ((y * (x ⋆ 1)) ⋆ z)"
    by (metis while_left_dist_sup while_productstar)
  finally show ?thesis
    .
qed

text ‹Theorem 10.10›

lemma while_sumstar_1:
  "(x ⊔ y) ⋆ z = (x ⋆ y) ⋆ ((x ⋆ 1) * z)"
  by (smt order.eq_iff order_trans while_sup_1_below while_sumstar while_sumstar_3_below while_sumstar_4_below)

text ‹Theorem 10.8›

lemma while_sumstar_2:
  "(x ⊔ y) ⋆ z = x ⋆ ((y * (x ⋆ 1)) ⋆ z)"
  using order.antisym while_sup_1_below while_sumstar_1 while_sumstar_4_below by auto

text ‹Theorem 10.9›

lemma while_sumstar_3:
  "(x ⊔ y) ⋆ z = ((x ⋆ 1) * y) ⋆ (x ⋆ z)"
  using order.antisym while_sumstar while_sumstar_1_below while_sumstar_2_below while_sumstar_2 by force

text ‹Theorem 10.6›

lemma while_decompose_6:
  "x ⋆ ((y * (x ⋆ 1)) ⋆ z) = y ⋆ ((x * (y ⋆ 1)) ⋆ z)"
  by (metis sup_commute while_sumstar_2)

text ‹Theorem 10.4›

lemma while_denest_4:
  "(x ⋆ w) ⋆ (x ⋆ (y * z)) = (x ⋆ w) ⋆ ((x ⋆ y) * z)"
proof -
  have "(x ⋆ w) ⋆ (x ⋆ (y * z)) = x ⋆ ((w * (x ⋆ 1)) ⋆ (y * z))"
    using while_sumstar while_sumstar_2 by force
  also have "... ≤ (x ⋆ w) ⋆ ((x ⋆ y) * z)"
    by (metis while_01 while_right_isotone while_02)
  finally show ?thesis
    using order.antisym while_right_isotone while_sub_associative by auto
qed

text ‹Theorem 10.13›

lemma while_denest_5:
  "w * ((x ⋆ (y * w)) ⋆ (x ⋆ (y * z))) = w * (((x ⋆ y) * w) ⋆ ((x ⋆ y) * z))"
  by (simp add: while_denest_2 while_denest_4)

text ‹Theorem 10.5›

lemma while_denest_6:
  "(w * (x ⋆ y)) ⋆ z = z ⊔ w * ((x ⊔ y * w) ⋆ (y * z))"
  by (metis while_denest_5 while_productstar while_sumstar)

text ‹Theorem 10.1›

lemma while_sum_below_one:
  "y * ((x ⊔ y) ⋆ z) ≤ (y * (x ⋆ 1)) ⋆ z"
  by (simp add: while_denest_6)

text ‹Theorem 10.14›

lemma while_separate_unfold:
  "(y * (x ⋆ 1)) ⋆ z = (y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ ((y * (x ⋆ 1)) ⋆ z))))"
proof -
  have "y ⋆ (y * x * (x ⋆ ((y * (x ⋆ 1)) ⋆ z))) ≤ y ⋆ (y * ((x ⊔ y) ⋆ z))"
    using mult_right_isotone while_left_plus_below while_right_isotone mult_assoc while_sumstar_2 by auto
  also have "... ≤ (y * (x ⋆ 1)) ⋆ z"
    by (metis sup_commute sup_ge1 while_absorb_1 while_mult_star_exchange while_sum_below_one)
  finally have "(y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ ((y * (x ⋆ 1)) ⋆ z)))) ≤ (y * (x ⋆ 1)) ⋆ z"
    using sup.bounded_iff while_back_loop_prefixpoint while_left_isotone by auto
  thus ?thesis
    by (simp add: order.antisym while_separate_unfold_below)
qed

text ‹Theorem 10.7›

lemma while_finite_associative:
  "x ⋆ bot = bot ⟹ (x ⋆ y) * z = x ⋆ (y * z)"
  by (metis while_denest_4 while_zero)

text ‹Theorem 12›

lemma atomicity_refinement:
  assumes "s = s * q"
      and "x = q * x"
      and "q * b = bot"
      and "r * b ≤ b * r"
      and "r * l ≤ l * r"
      and "x * l ≤ l * x"
      and "b * l ≤ l * b"
      and "q * l ≤ l * q"
      and "r ⋆ q ≤ q * (r ⋆ 1) ∧ q ≤ 1"
    shows "s * ((x ⊔ b ⊔ r ⊔ l) ⋆ (q * z)) ≤ s * ((x * (b ⋆ q) ⊔ r ⊔ l) ⋆ z)"
proof -
  have 1: "(x ⊔ b ⊔ r) * l ≤ l * (x ⊔ b ⊔ r)"
    by (smt assms(5-7) mult_left_dist_sup semiring.add_mono semiring.distrib_right)
  have "q * ((x * (b ⋆ r ⋆ 1) * q) ⋆ z) ≤ (x * (b ⋆ r ⋆ 1) * q) ⋆ z"
    using assms(9) order_lesseq_imp while_increasing while_mult_upper_bound by blast
  also have "... ≤ (x * (b ⋆ ((r ⋆ 1) * q))) ⋆ z"
    by (simp add: mult_right_isotone while_left_isotone while_sub_associative mult_assoc)
  also have "... ≤ (x * (b ⋆ r ⋆ q)) ⋆ z"
    by (simp add: mult_right_isotone while_left_isotone while_one_mult_below while_right_isotone)
  also have "... ≤ (x * (b ⋆ (q * (r ⋆ 1)))) ⋆ z"
    by (simp add: assms(9) mult_right_isotone while_left_isotone while_right_isotone)
  finally have 2: "q * ((x * (b ⋆ r ⋆ 1) * q) ⋆ z) ≤ (x * (b ⋆ q) * (r ⋆ 1)) ⋆ z"
    using while_associative_while_1 mult_assoc by auto
  have "s * ((x ⊔ b ⊔ r ⊔ l) ⋆ (q * z)) = s * (l ⋆ (x ⊔ b ⊔ r) ⋆ (q * z))"
    using 1 sup_commute while_separate_1 by fastforce
  also have "... = s * q * (l ⋆ b ⋆ r ⋆ (q * x * (b ⋆ r ⋆ 1)) ⋆ (q * z))"
    by (smt assms(1,2,4) sup_assoc sup_commute while_sumstar_2 while_separate_1)
  also have "... = s * q * (l ⋆ b ⋆ r ⋆ (q * ((x * (b ⋆ r ⋆ 1) * q) ⋆ z)))"
    by (simp add: while_slide mult_assoc)
  also have "... ≤ s * q * (l ⋆ b ⋆ r ⋆ (x * (b ⋆ q) * (r ⋆ 1)) ⋆ z)"
    using 2 by (meson mult_right_isotone while_right_isotone)
  also have "... ≤ s * (l ⋆ q * (b ⋆ r ⋆ (x * (b ⋆ q) * (r ⋆ 1)) ⋆ z))"
    by (simp add: assms(8) mult_right_isotone while_simulate mult_assoc)
  also have "... = s * (l ⋆ q * (r ⋆ (x * (b ⋆ q) * (r ⋆ 1)) ⋆ z))"
    using assms(3) while_elimination by auto
  also have "... ≤ s * (l ⋆ r ⋆ (x * (b ⋆ q) * (r ⋆ 1)) ⋆ z)"
    by (meson assms(9) order.trans mult_right_isotone order.refl while_increasing while_mult_upper_bound while_right_isotone)
  also have "... = s * (l ⋆ (r ⊔ x * (b ⋆ q)) ⋆ z)"
    by (simp add: while_sumstar_2)
  also have "... ≤ s * ((x * (b ⋆ q) ⊔ r ⊔ l) ⋆ z)"
    using mult_right_isotone sup_commute while_sub_dist_3 by auto
  finally show ?thesis
    .
qed

end

class bounded_extended_binary_itering = bounded_binary_itering + extended_binary_itering

end

Theory Binary_Iterings_Strict

(* Title:      Strict Binary Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Strict Binary Iterings›

theory Binary_Iterings_Strict

imports Stone_Kleene_Relation_Algebras.Iterings Binary_Iterings

begin

class strict_itering = itering + while +
  assumes while_def: "x ⋆ y = x⇧^∘ * y"
begin

text ‹Theorem 8.1›

subclass extended_binary_itering
  apply unfold_locales
  apply (metis circ_loop_fixpoint circ_slide_1 sup_commute while_def mult_assoc)
  apply (metis circ_sup mult_assoc while_def)
  apply (simp add: mult_left_dist_sup while_def)
  apply (simp add: while_def mult_assoc)
  apply (metis circ_simulate_left_plus mult_assoc mult_left_isotone mult_right_dist_sup mult_1_right while_def)
  apply (metis circ_simulate_right_plus mult_assoc mult_left_isotone mult_right_dist_sup while_def)
  by (metis circ_loop_fixpoint mult_right_sub_dist_sup_right while_def mult_assoc)

text ‹Theorem 13.1›

lemma while_associative:
  "(x ⋆ y) * z = x ⋆ (y * z)"
  by (simp add: while_def mult_assoc)

text ‹Theorem 13.3›

lemma while_one_mult:
  "(x ⋆ 1) * x = x ⋆ x"
  by (simp add: while_def)

lemma while_back_loop_is_fixpoint:
  "is_fixpoint (λx . x * y ⊔ z) (z * (y ⋆ 1))"
  by (simp add: circ_back_loop_is_fixpoint while_def)

text ‹Theorem 13.4›

lemma while_sumstar_var:
  "(x ⊔ y) ⋆ z = ((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z)"
  by (simp add: while_sumstar_3 while_associative)

text ‹Theorem 13.2›

lemma while_mult_1_assoc:
  "(x ⋆ 1) * y = x ⋆ y"
  by (simp add: while_def)

(*
lemma "y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
lemma "y * x ≤ (1 ⊔ x) * (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
lemma while_square_1: "x ⋆ 1 = (x * x) ⋆ (x ⊔ 1)" oops
lemma while_absorb_below_one: "y * x ≤ x ⟹ y ⋆ x ≤ 1 ⋆ x" oops
*)

end

class bounded_strict_itering = bounded_itering + strict_itering
begin

subclass bounded_extended_binary_itering ..

text ‹Theorem 13.6›

lemma while_top_2:
  "top ⋆ z = top * z"
  by (simp add: circ_top while_def)

text ‹Theorem 13.5›

lemma while_mult_top_2:
  "(x * top) ⋆ z = z ⊔ x * top * z"
  by (metis circ_left_top mult_assoc while_def while_left_unfold)

text ‹Theorem 13 counterexamples›

(*
lemma while_one_top: "1 ⋆ x = top" nitpick [expect=genuine,card=2] oops
lemma while_top: "top ⋆ x = top" nitpick [expect=genuine,card=2] oops
lemma while_sub_mult_one: "x * (1 ⋆ y) ≤ 1 ⋆ x" oops
lemma while_unfold_below_1: "x = y * x ⟹ x ≤ y ⋆ 1" oops
lemma while_unfold_below: "x = z ⊔ y * x ⟹ x ≤ y ⋆ z" nitpick [expect=genuine,card=2] oops
lemma while_unfold_below: "x ≤ z ⊔ y * x ⟹ x ≤ y ⋆ z" nitpick [expect=genuine,card=2] oops
lemma while_mult_top: "(x * top) ⋆ z = z ⊔ x * top" nitpick [expect=genuine,card=2] oops
lemma tarski_mult_top_idempotent: "x * top = x * top * x * top" oops

lemma while_loop_is_greatest_postfixpoint: "is_greatest_postfixpoint (λx . y * x ⊔ z) (y ⋆ z)" nitpick [expect=genuine,card=2] oops
lemma while_loop_is_greatest_fixpoint: "is_greatest_fixpoint (λx . y * x ⊔ z) (y ⋆ z)" nitpick [expect=genuine,card=2] oops
lemma while_sub_while_zero: "x ⋆ z ≤ (x ⋆ y) ⋆ z" oops
lemma while_while_sub_associative: "x ⋆ (y ⋆ z) ≤ (x ⋆ y) ⋆ z" oops
lemma tarski: "x ≤ x * top * x * top" oops
lemma tarski_top_omega_below: "x * top ≤ (x * top) ⋆ bot" nitpick [expect=genuine,card=2] oops
lemma tarski_top_omega: "x * top = (x * top) ⋆ bot" nitpick [expect=genuine,card=2] oops
lemma tarski_below_top_omega: "x ≤ (x * top) ⋆ bot" nitpick [expect=genuine,card=2] oops
lemma tarski: "x = bot ∨ top * x * top = top" oops
lemma "1 = (x * bot) ⋆ 1" oops
lemma "1 ⊔ x * bot = x ⋆ 1" oops
lemma "x = x * (x ⋆ 1)" oops
lemma "x * (x ⋆ 1) = x ⋆ 1" oops
lemma "x ⋆ 1 = x ⋆ (1 ⋆ 1)" oops
lemma "(x ⊔ y) ⋆ 1 = (x ⋆ (y ⋆ 1)) ⋆ 1" oops
lemma "z ⊔ y * x = x ⟹ y ⋆ z ≤ x" oops
lemma "y * x = x ⟹ y ⋆ x ≤ x" oops
lemma "z ⊔ x * y = x ⟹ z * (y ⋆ 1) ≤ x" oops
lemma "x * y = x ⟹ x * (y ⋆ 1) ≤ x" oops
lemma "x * z = z * y ⟹ x ⋆ z ≤ z * (y ⋆ 1)" oops
*)

end

class binary_itering_unary = extended_binary_itering + circ +
  assumes circ_def: "x⇧^∘ = x ⋆ 1"
begin

text ‹Theorem 50.7›

subclass left_conway_semiring
  apply unfold_locales
  using circ_def while_left_unfold apply simp
  apply (metis circ_def mult_1_right while_one_mult_below while_slide)
  using circ_def while_one_while while_sumstar_2 by auto

end

class strict_binary_itering = binary_itering + circ +
  assumes while_associative: "(x ⋆ y) * z = x ⋆ (y * z)"
  assumes circ_def: "x⇧^∘ = x ⋆ 1"
begin

text ‹Theorem 2.8›

subclass itering
  apply unfold_locales
  apply (simp add: circ_def while_associative while_sumstar)
  apply (metis circ_def mult_1_right while_associative while_productstar while_slide)
  apply (metis circ_def mult_1_right while_associative mult_1_left while_slide while_simulate_right_plus)
  by (metis circ_def mult_1_right while_associative mult_1_left while_simulate_left_plus mult_right_dist_sup)

text ‹Theorem 8.5›

subclass extended_binary_itering
  apply unfold_locales
  by (simp add: while_associative while_increasing mult_assoc)

end

end

Theory Binary_Iterings_Nonstrict

(* Title:      Nonstrict Binary Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Nonstrict Binary Iterings›

theory Binary_Iterings_Nonstrict

imports Omega_Algebras Binary_Iterings

begin

class nonstrict_itering = bounded_left_zero_omega_algebra + while +
  assumes while_def: "x ⋆ y = x⇧^ω ⊔ x⇧^⋆ * y"
begin

text ‹Theorem 8.2›

subclass bounded_binary_itering
proof (unfold_locales)
  fix x y z
  show "(x * y) ⋆ z = z ⊔ x * ((y * x) ⋆ (y * z))"
    by (metis sup_commute mult_assoc mult_left_dist_sup omega_loop_fixpoint omega_slide star.circ_slide while_def)
next
  fix x y z
  show "(x ⊔ y) ⋆ z = (x ⋆ y) ⋆ (x ⋆ z)"
  proof -
    have 1: "(x ⊔ y) ⋆ z = (x⇧^⋆ * y)⇧^ω ⊔ (x⇧^⋆ * y)⇧^⋆ * (x⇧^ω ⊔ x⇧^⋆ * z)"
      using mult_left_dist_sup omega_decompose star.circ_sup_9 sup_assoc while_def mult_assoc by auto
    hence 2: "(x ⊔ y) ⋆ z ≤ (x ⋆ y) ⋆ (x ⋆ z)"
      by (smt sup_mono sup_ge2 le_iff_sup mult_left_isotone omega_sub_dist star.circ_sub_dist while_def)
    let ?rhs = "x⇧^⋆ * y * ((x⇧^ω ⊔ x⇧^⋆ * y)⇧^ω ⊔ (x⇧^ω ⊔ x⇧^⋆ * y)⇧^⋆ * (x⇧^ω ⊔ x⇧^⋆ * z)) ⊔ (x⇧^ω ⊔ x⇧^⋆ * z)"
    have "x⇧^ω * (x⇧^ω ⊔ x⇧^⋆ * y)⇧^ω ≤ x⇧^ω"
      by (simp add: omega_sub_vector)
    hence "x⇧^ω * (x⇧^ω ⊔ x⇧^⋆ * y)⇧^ω ⊔ x⇧^⋆ * y * (x⇧^ω ⊔ x⇧^⋆ * y)⇧^ω ≤ ?rhs"
      by (smt sup_commute sup_mono sup_ge1 mult_left_dist_sup order_trans)
    hence 3: "(x⇧^ω ⊔ x⇧^⋆ * y)⇧^ω ≤ ?rhs"
      by (metis mult_right_dist_sup omega_unfold)
    have "x⇧^ω * (x⇧^ω ⊔ x⇧^⋆ * y)⇧^⋆ * (x⇧^ω ⊔ x⇧^⋆ * z) ≤ x⇧^ω"
      by (simp add: omega_mult_star_2 omega_sub_vector)
    hence "x⇧^ω * (x⇧^ω ⊔ x⇧^⋆ * y)⇧^⋆ * (x⇧^ω ⊔ x⇧^⋆ * z) ⊔ x⇧^⋆ * y * (x⇧^ω ⊔ x⇧^⋆ * y)⇧^⋆ * (x⇧^ω ⊔ x⇧^⋆ * z) ≤ ?rhs"
      by (smt sup_commute sup_mono sup_ge2 mult_assoc mult_left_dist_sup order_trans)
    hence "(x⇧^ω ⊔ x⇧^⋆ * y)⇧^⋆ * (x⇧^ω ⊔ x⇧^⋆ * z) ≤ ?rhs"
      by (smt sup_assoc sup_ge2 le_iff_sup mult_assoc mult_right_dist_sup star.circ_loop_fixpoint)
    hence "(x⇧^ω ⊔ x⇧^⋆ * y)⇧^ω ⊔ (x⇧^ω ⊔ x⇧^⋆ * y)⇧^⋆ * (x⇧^ω ⊔ x⇧^⋆ * z) ≤ ?rhs"
      using 3 by simp
    hence "(x⇧^ω ⊔ x⇧^⋆ * y)⇧^ω ⊔ (x⇧^ω ⊔ x⇧^⋆ * y)⇧^⋆ * (x⇧^ω ⊔ x⇧^⋆ * z) ≤ (x⇧^⋆ * y)⇧^ω ⊔ (x⇧^⋆ * y)⇧^⋆ * (x⇧^ω ⊔ x⇧^⋆ * z)"
      by (metis sup_commute omega_induct)
    thus ?thesis
      using 1 2 order.antisym while_def by force
  qed
next
  fix x y z
  show "x ⋆ (y ⊔ z) = (x ⋆ y) ⊔ (x ⋆ z)"
    using mult_left_dist_sup sup_assoc sup_commute while_def by auto
next
  fix x y z
  show "(x ⋆ y) * z ≤ x ⋆ (y * z)"
    using mult_semi_associative omega_sub_vector semiring.add_mono semiring.distrib_right while_def by fastforce
next
  fix v w x y z
  show "x * z ≤ z * (y ⋆ 1) ⊔ w ⟶ x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ (w * (y ⋆ v)))"
  proof
    assume "x * z ≤ z * (y ⋆ 1) ⊔ w"
    hence 1: "x * z ≤ z * y⇧^ω ⊔ z * y⇧^⋆ ⊔ w"
      by (metis mult_left_dist_sup mult_1_right while_def)
    let ?rhs = "z * (y⇧^ω ⊔ y⇧^⋆ * v) ⊔ x⇧^ω ⊔ x⇧^⋆ * w * (y⇧^ω ⊔ y⇧^⋆ * v)"
    have 2: "z * v ≤ ?rhs"
      by (metis le_supI1 mult_left_sub_dist_sup_right omega_loop_fixpoint)
    have "x * z * (y⇧^ω ⊔ y⇧^⋆ * v) ≤ ?rhs"
    proof -
      have "x * z * (y⇧^ω ⊔ y⇧^⋆ * v) ≤ (z * y⇧^ω ⊔ z * y⇧^⋆ ⊔ w) * (y⇧^ω ⊔ y⇧^⋆ * v)"
        using 1 mult_left_isotone by auto
      also have "... = z * (y⇧^ω * (y⇧^ω ⊔ y⇧^⋆ * v) ⊔ y⇧^⋆ * (y⇧^ω ⊔ y⇧^⋆ * v)) ⊔ w * (y⇧^ω ⊔ y⇧^⋆ * v)"
        by (smt mult_assoc mult_left_dist_sup mult_right_dist_sup)
      also have "... = z * (y⇧^ω * (y⇧^ω ⊔ y⇧^⋆ * v) ⊔ y⇧^ω ⊔ y⇧^⋆ * v) ⊔ w * (y⇧^ω ⊔ y⇧^⋆ * v)"
        by (smt sup_assoc mult_assoc mult_left_dist_sup star.circ_transitive_equal star_mult_omega)
      also have "... ≤ z * (y⇧^ω ⊔ y⇧^⋆ * v) ⊔ x⇧^⋆ * w * (y⇧^ω ⊔ y⇧^⋆ * v)"
        by (smt sup_commute sup_mono sup_left_top mult_left_dist_sup mult_left_one mult_right_dist_sup mult_right_sub_dist_sup_left omega_vector order_refl star.circ_plus_one)
      finally show ?thesis
        by (smt sup_assoc sup_commute le_iff_sup)
    qed
    hence "x * ?rhs ≤ ?rhs"
      by (smt sup_assoc sup_commute sup_ge1 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup omega_unfold star.circ_increasing star.circ_transitive_equal)
    hence "z * v ⊔ x * ?rhs ≤ ?rhs"
      using 2 le_supI by blast
    hence "x⇧^⋆ * z * v ≤ ?rhs"
      by (simp add: star_left_induct mult_assoc)
    hence "x⇧^ω ⊔ x⇧^⋆ * z * v ≤ ?rhs"
      by (meson order_trans sup_ge1 sup_ge2 sup_least)
    thus "x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ (w * (y ⋆ v)))"
      by (simp add: sup_assoc while_def mult_assoc)
  qed
next
  fix v w x y z
  show "z * x ≤ y * (y ⋆ z) ⊔ w ⟶ z * (x ⋆ v) ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
  proof
    assume "z * x ≤ y * (y ⋆ z) ⊔ w"
    hence "z * x ≤ y * (y⇧^ω ⊔ y⇧^⋆ * z) ⊔ w"
      by (simp add: while_def)
    hence 1: "z * x ≤ y⇧^ω ⊔ y * y⇧^⋆ * z ⊔ w"
      using mult_left_dist_sup omega_unfold mult_assoc by auto
    let ?rhs = "y⇧^ω ⊔ y⇧^⋆ * z * v ⊔ y⇧^⋆ * w * (x⇧^ω ⊔ x⇧^⋆ * v)"
    have 2: "z * x⇧^ω ≤ ?rhs"
    proof -
      have "z * x⇧^ω ≤ y * y⇧^⋆ * z * x⇧^ω ⊔ y⇧^ω * x⇧^ω ⊔ w * x⇧^ω"
        using 1 by (smt sup_commute le_iff_sup mult_assoc mult_right_dist_sup omega_unfold)
      also have "... ≤ y * y⇧^⋆ * z * x⇧^ω ⊔ y⇧^ω ⊔ w * x⇧^ω"
        using omega_sub_vector semiring.add_mono by blast
      also have "... = y * y⇧^⋆ * (z * x⇧^ω) ⊔ (y⇧^ω ⊔ w * x⇧^ω)"
        by (simp add: sup_assoc mult_assoc)
      finally have "z * x⇧^ω ≤ (y * y⇧^⋆)⇧^ω ⊔ (y * y⇧^⋆)⇧^⋆ * (y⇧^ω ⊔ w * x⇧^ω)"
        by (simp add: omega_induct sup_commute)
      also have "... = y⇧^ω ⊔ y⇧^⋆ * w * x⇧^ω"
        by (simp add: left_plus_omega semiring.distrib_left star.left_plus_circ star_mult_omega mult_assoc)
      also have "... ≤ ?rhs"
        using mult_left_sub_dist_sup_left sup.mono sup_ge1 by blast
      finally show ?thesis
        .
    qed
    let ?rhs2 = "y⇧^ω ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * (x⇧^ω ⊔ x⇧^⋆)"
    have "?rhs2 * x ≤ ?rhs2"
    proof -
      have 3: "y⇧^ω * x ≤ ?rhs2"
        by (simp add: le_supI1 omega_sub_vector)
      have "y⇧^⋆ * z * x ≤ y⇧^⋆ * (y⇧^ω ⊔ y * y⇧^⋆ * z ⊔ w)"
        using 1 mult_right_isotone mult_assoc by auto
      also have "... = y⇧^ω ⊔ y⇧^⋆ * y * y⇧^⋆ * z ⊔ y⇧^⋆ * w"
        by (simp add: semiring.distrib_left star_mult_omega mult_assoc)
      also have "... = y⇧^ω ⊔ y * y⇧^⋆ * z ⊔ y⇧^⋆ * w"
        by (simp add: star.circ_plus_same star.circ_transitive_equal mult_assoc)
      also have "... ≤ y⇧^ω ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w"
        by (metis sup_left_isotone sup_right_isotone mult_left_isotone star.left_plus_below_circ)
      also have "... ≤ y⇧^ω ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * x⇧^⋆"
        using semiring.add_left_mono star.circ_back_loop_prefixpoint by auto
      finally have 4: "y⇧^⋆ * z * x ≤ ?rhs2"
        using mult_left_sub_dist_sup_right order_lesseq_imp semiring.add_left_mono by blast
      have "(x⇧^ω ⊔ x⇧^⋆) * x ≤ x⇧^ω ⊔ x⇧^⋆"
        using omega_sub_vector semiring.distrib_right star.left_plus_below_circ star_plus sup_mono by fastforce
      hence "y⇧^⋆ * w * (x⇧^ω ⊔ x⇧^⋆) * x ≤ ?rhs2"
        by (simp add: le_supI2 mult_right_isotone mult_assoc)
      thus ?thesis
        using 3 4 mult_right_dist_sup by force
    qed
    hence "z ⊔ ?rhs2 * x ≤ ?rhs2"
      by (metis omega_loop_fixpoint sup.boundedE sup_ge1 sup_least)
    hence 5: "z * x⇧^⋆ ≤ ?rhs2"
      using star_right_induct by blast
    have "z * x⇧^⋆ * v ≤ ?rhs"
    proof -
      have "z * x⇧^⋆ * v ≤ ?rhs2 * v"
        using 5 mult_left_isotone by auto
      also have "... = y⇧^ω * v ⊔ y⇧^⋆ * z * v ⊔ y⇧^⋆ * w * (x⇧^ω * v ⊔ x⇧^⋆ * v)"
        using mult_right_dist_sup mult_assoc by auto
      also have "... ≤ y⇧^ω ⊔ y⇧^⋆ * z * v ⊔ y⇧^⋆ * w * (x⇧^ω * v ⊔ x⇧^⋆ * v)"
        using omega_sub_vector semiring.add_right_mono by blast
      also have "... ≤ ?rhs"
        using mult_right_isotone omega_sub_vector semiring.add_left_mono semiring.add_right_mono by auto
      finally show ?thesis
        .
    qed
    hence "z * (x⇧^ω ⊔ x⇧^⋆ * v) ≤ ?rhs"
      using 2 semiring.distrib_left mult_assoc by force
    thus "z * (x ⋆ v) ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
      by (simp add: semiring.distrib_left sup_assoc while_def mult_assoc)
  qed
qed

text ‹Theorem 13.8›

lemma while_top:
  "top ⋆ x = top"
  by (metis sup_left_top star.circ_top star_omega_top while_def)

text ‹Theorem 13.7›

lemma while_one_top:
  "1 ⋆ x = top"
  by (simp add: omega_one while_def)

lemma while_finite_associative:
  "x⇧^ω = bot ⟹ (x ⋆ y) * z = x ⋆ (y * z)"
  by (simp add: while_def mult_assoc)

lemma star_below_while:
  "x⇧^⋆ * y ≤ x ⋆ y"
  by (simp add: while_def)

text ‹Theorem 13.9›

lemma while_sub_mult_one:
  "x * (1 ⋆ y) ≤ 1 ⋆ x"
  by (simp add: omega_one while_def)

lemma while_while_one:
  "y ⋆ (x ⋆ 1) = y⇧^ω ⊔ y⇧^⋆ * x⇧^ω ⊔ y⇧^⋆ * x⇧^⋆"
  using mult_left_dist_sup sup_assoc while_def by auto

lemma while_simulate_4_plus:
  assumes "y * x ≤ x * (x ⋆ (1 ⊔ y))"
    shows "y * x * x⇧^⋆ ≤ x * (x ⋆ (1 ⊔ y))"
proof -
  have 1: "x * (x ⋆ (1 ⊔ y)) = x⇧^ω ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y"
    using mult_left_dist_sup omega_unfold sup_assoc while_def mult_assoc by force
  hence "y * x * x⇧^⋆ ≤ (x⇧^ω ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y) * x⇧^⋆"
    using assms mult_left_isotone by auto
  also have "... = x⇧^ω * x⇧^⋆ ⊔ x * x⇧^⋆ * x⇧^⋆ ⊔ x * x⇧^⋆ * y * x⇧^⋆"
    using mult_right_dist_sup by force
  also have "... = x * x⇧^⋆ * (y * x * x⇧^⋆) ⊔ x⇧^ω ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y"
    by (smt sup_assoc sup_commute mult_assoc omega_mult_star_2 star.circ_back_loop_fixpoint star.circ_plus_same star.circ_transitive_equal)
  finally have "y * x * x⇧^⋆ ≤ x * x⇧^⋆ * (y * x * x⇧^⋆) ⊔ (x⇧^ω ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y)"
    using sup_assoc by force
  hence "y * x * x⇧^⋆ ≤ (x * x⇧^⋆)⇧^ω ⊔ (x * x⇧^⋆)⇧^⋆ * (x⇧^ω ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y)"
    by (simp add: omega_induct sup_monoid.add_commute)
  also have "... = x⇧^ω ⊔ x⇧^⋆ * (x⇧^ω ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y)"
    by (simp add: left_plus_omega star.left_plus_circ)
  finally show ?thesis
    using 1 by (metis while_def while_mult_star_exchange while_transitive)
qed

lemma while_simulate_4_omega:
  assumes "y * x ≤ x * (x ⋆ (1 ⊔ y))"
    shows "y * x⇧^ω ≤ x⇧^ω"
proof -
  have "x * (x ⋆ (1 ⊔ y)) = x⇧^ω ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y"
    using mult_1_right mult_left_dist_sup omega_unfold sup_assoc while_def mult_assoc by auto
  hence "y * x⇧^ω ≤ (x⇧^ω ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y) * x⇧^ω"
    by (smt assms le_iff_sup mult_assoc mult_right_dist_sup omega_unfold)
  also have "... = x⇧^ω * x⇧^ω ⊔ x * x⇧^⋆ * x⇧^ω ⊔ x * x⇧^⋆ * y * x⇧^ω"
    using semiring.distrib_right by auto
  also have "... = x * x⇧^⋆ * (y * x⇧^ω) ⊔ x⇧^ω"
    by (metis sup_commute le_iff_sup mult_assoc omega_sub_vector omega_unfold star_mult_omega)
  finally have "y * x⇧^ω ≤ x * x⇧^⋆ * (y * x⇧^ω) ⊔ x⇧^ω"
    .
  hence "y * x⇧^ω ≤ (x * x⇧^⋆)⇧^ω ⊔ (x * x⇧^⋆)⇧^⋆ * x⇧^ω"
    by (simp add: omega_induct sup_commute)
  thus ?thesis
    by (metis sup_idem left_plus_omega star_mult_omega)
qed

text ‹Theorem 13.11›

lemma while_unfold_below:
  "x = z ⊔ y * x ⟹ x ≤ y ⋆ z"
  by (simp add: omega_induct while_def)

text ‹Theorem 13.12›

lemma while_unfold_below_sub:
  "x ≤ z ⊔ y * x ⟹ x ≤ y ⋆ z"
  by (simp add: omega_induct while_def)

text ‹Theorem 13.10›

lemma while_unfold_below_1:
  "x = y * x ⟹ x ≤ y ⋆ 1"
  by (simp add: while_unfold_below_sub)

lemma while_square_1:
  "x ⋆ 1 = (x * x) ⋆ (x ⊔ 1)"
  by (metis mult_1_right omega_square star_square_2 while_def)

lemma while_absorb_below_one:
  "y * x ≤ x ⟹ y ⋆ x ≤ 1 ⋆ x"
  by (simp add: while_unfold_below_sub)

lemma while_loop_is_greatest_postfixpoint:
  "is_greatest_postfixpoint (λx . y * x ⊔ z) (y ⋆ z)"
proof -
  have "(y ⋆ z) ≤ (λx . y * x ⊔ z) (y ⋆ z)"
    using sup_commute while_left_unfold by force
  thus ?thesis
    by (simp add: is_greatest_postfixpoint_def sup_commute while_unfold_below_sub)
qed

lemma while_loop_is_greatest_fixpoint:
  "is_greatest_fixpoint (λx . y * x ⊔ z) (y ⋆ z)"
  by (simp add: omega_loop_is_greatest_fixpoint while_def)

(*
lemma while_sumstar_4_below: "(x ⋆ y) ⋆ ((x ⋆ 1) * z) ≤ x ⋆ ((y * (x ⋆ 1)) ⋆ z)" nitpick [expect=genuine,card=6] oops
lemma while_sumstar_2: "(x ⊔ y) ⋆ z = x ⋆ ((y * (x ⋆ 1)) ⋆ z)" nitpick [expect=genuine,card=6] oops
lemma while_sumstar_3: "(x ⊔ y) ⋆ z = ((x ⋆ 1) * y) ⋆ (x ⋆ z)" oops
lemma while_decompose_6: "x ⋆ ((y * (x ⋆ 1)) ⋆ z) = y ⋆ ((x * (y ⋆ 1)) ⋆ z)" nitpick [expect=genuine,card=6] oops
lemma while_finite_associative: "x ⋆ bot = bot ⟹ (x ⋆ y) * z = x ⋆ (y * z)" oops
lemma atomicity_refinement: "s = s * q ⟹ x = q * x ⟹ q * b = bot ⟹ r * b ≤ b * r ⟹ r * l ≤ l * r ⟹ x * l ≤ l * x ⟹ b * l ≤ l * b ⟹ q * l ≤ l * q ⟹ r ⋆ q ≤ q * (r ⋆ 1) ⟹ q ≤ 1 ⟹ s * ((x ⊔ b ⊔ r ⊔ l) ⋆ (q * z)) ≤ s * ((x * (b ⋆ q) ⊔ r ⊔ l) ⋆ z)" oops

lemma while_separate_right_plus: "y * x ≤ x * (x ⋆ (1 ⊔ y)) ⊔ 1 ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)" oops
lemma "y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
lemma "y * x ≤ (1 ⊔ x) * (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops

lemma while_mult_sub_while_while: "x ⋆ (y * z) ≤ (x ⋆ y) ⋆ z" oops
lemma while_zero_zero: "(x ⋆ bot) ⋆ bot = x ⋆ bot" oops
lemma while_denest_3: "(x ⋆ w) ⋆ (x ⋆ bot) = (x ⋆ w) ⋆ bot" oops
lemma while_02: "x ⋆ ((x ⋆ w) ⋆ ((x ⋆ y) * z)) = (x ⋆ w) ⋆ ((x ⋆ y) * z)" oops
lemma while_sumstar_3_below: "(x ⋆ y) ⋆ (x ⋆ z) ≤ (x ⋆ y) ⋆ ((x ⋆ 1) * z)" oops
lemma while_sumstar_1: "(x ⊔ y) ⋆ z = (x ⋆ y) ⋆ ((x ⋆ 1) * z)" oops
lemma while_denest_4: "(x ⋆ w) ⋆ (x ⋆ (y * z)) = (x ⋆ w) ⋆ ((x ⋆ y) * z)" oops
*)

end

class nonstrict_itering_zero = nonstrict_itering +
  assumes mult_right_zero: "x * bot = bot"
begin

lemma while_finite_associative_2:
  "x ⋆ bot = bot ⟹ (x ⋆ y) * z = x ⋆ (y * z)"
  by (metis sup_bot_left sup_bot_right mult_assoc mult_right_zero while_def)

text ‹Theorem 13 counterexamples›

(*
lemma while_mult_top: "(x * top) ⋆ z = z ⊔ x * top" nitpick [expect=genuine,card=3] oops
lemma tarski_mult_top_idempotent: "x * top = x * top * x * top" nitpick [expect=genuine,card=3] oops

lemma while_denest_0: "w * (x ⋆ (y * z)) ≤ (w * (x ⋆ y)) ⋆ (w * (x ⋆ y) * z)" nitpick [expect=genuine,card=3] oops
lemma while_denest_1: "w * (x ⋆ (y * z)) ≤ (w * (x ⋆ y)) ⋆ z" nitpick [expect=genuine,card=3] oops
lemma while_mult_zero_zero: "(x * (y ⋆ bot)) ⋆ bot = x * (y ⋆ bot)" nitpick [expect=genuine,card=3] oops
lemma while_denest_2: "w * ((x ⋆ (y * w)) ⋆ z) = w * (((x ⋆ y) * w) ⋆ z)" nitpick [expect=genuine,card=3] oops
lemma while_denest_5: "w * ((x ⋆ (y * w)) ⋆ (x ⋆ (y * z))) = w * (((x ⋆ y) * w) ⋆ ((x ⋆ y) * z))" nitpick [expect=genuine,card=3] oops
lemma while_denest_6: "(w * (x ⋆ y)) ⋆ z = z ⊔ w * ((x ⊔ y * w) ⋆ (y * z))" nitpick [expect=genuine,card=3] oops
lemma while_sum_below_one: "y * ((x ⊔ y) ⋆ z) ≤ (y * (x ⋆ 1)) ⋆ z" nitpick [expect=genuine,card=3] oops
lemma while_separate_unfold: "(y * (x ⋆ 1)) ⋆ z = (y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ ((y * (x ⋆ 1)) ⋆ z))))" nitpick [expect=genuine,card=3] oops

lemma while_sub_while_zero: "x ⋆ z ≤ (x ⋆ y) ⋆ z" nitpick [expect=genuine,card=4] oops
lemma while_while_sub_associative: "x ⋆ (y ⋆ z) ≤ (x ⋆ y) ⋆ z" nitpick [expect=genuine,card=4] oops
lemma tarski: "x ≤ x * top * x * top" nitpick [expect=genuine,card=3] oops
lemma tarski_top_omega_below: "x * top ≤ (x * top)⇧^ω" nitpick [expect=genuine,card=3] oops
lemma tarski_top_omega: "x * top = (x * top)⇧^ω" nitpick [expect=genuine,card=3] oops
lemma tarski_below_top_omega: "x ≤ (x * top)⇧^ω" nitpick [expect=genuine,card=3] oops
lemma tarski_mult_omega_omega: "(x * y⇧^ω)⇧^ω = x * y⇧^ω" nitpick [expect=genuine,card=3] oops
lemma tarski_mult_omega_omega: "(∀z . z⇧^ω⇧^ω = z⇧^ω) ⟹ (x * y⇧^ω)⇧^ω = x * y⇧^ω" nitpick [expect=genuine,card=3] oops
lemma tarski: "x = bot ∨ top * x * top = top" nitpick [expect=genuine,card=3] oops
*)

end

class nonstrict_itering_tarski = nonstrict_itering +
  assumes tarski: "x ≤ x * top * x * top"
begin

text ‹Theorem 13.14›

lemma tarski_mult_top_idempotent:
  "x * top = x * top * x * top"
  by (metis sup_commute le_iff_sup mult_assoc star.circ_back_loop_fixpoint star.circ_left_top tarski top_mult_top)

lemma tarski_top_omega_below:
  "x * top ≤ (x * top)⇧^ω"
  using omega_induct_mult order.refl mult_assoc tarski_mult_top_idempotent by auto

lemma tarski_top_omega:
  "x * top = (x * top)⇧^ω"
  by (simp add: order.eq_iff mult_top_omega tarski_top_omega_below)

lemma tarski_below_top_omega:
  "x ≤ (x * top)⇧^ω"
  using top_right_mult_increasing tarski_top_omega by auto

lemma tarski_mult_omega_omega:
  "(x * y⇧^ω)⇧^ω = x * y⇧^ω"
  by (metis mult_assoc omega_vector tarski_top_omega)

lemma tarski_omega_idempotent:
  "x⇧^ω⇧^ω = x⇧^ω"
  by (metis omega_vector tarski_top_omega)

lemma while_denest_2a:
  "w * ((x ⋆ (y * w)) ⋆ z) = w * (((x ⋆ y) * w) ⋆ z)"
proof -
  have "(x⇧^ω ⊔ x⇧^⋆ * y * w)⇧^ω = (x⇧^⋆ * y * w)⇧^⋆ * x⇧^ω * (((x⇧^⋆ * y * w)⇧^⋆ * x⇧^ω)⇧^ω ⊔ ((x⇧^⋆ * y * w)⇧^⋆ * x⇧^ω)⇧^⋆ * (x⇧^⋆ * y * w)⇧^ω) ⊔ (x⇧^⋆ * y * w)⇧^ω"
    by (metis sup_commute omega_decompose omega_loop_fixpoint)
  also have "... ≤ (x⇧^⋆ * y * w)⇧^⋆ * x⇧^ω ⊔ (x⇧^⋆ * y * w)⇧^ω"
    by (metis sup_left_isotone mult_assoc mult_right_isotone omega_sub_vector)
  finally have 1: "w * (x⇧^ω ⊔ x⇧^⋆ * y * w)⇧^ω ≤ (w * x⇧^⋆ * y)⇧^⋆ * w * x⇧^ω ⊔ (w * x⇧^⋆ * y)⇧^ω"
    by (smt sup_commute le_iff_sup mult_assoc mult_left_dist_sup while_def while_slide)
  have "(x⇧^ω ⊔ x⇧^⋆ * y * w)⇧^⋆ * z = (x⇧^⋆ * y * w)⇧^⋆ * x⇧^ω * ((x⇧^⋆ * y * w)⇧^⋆ * x⇧^ω)⇧^⋆ * (x⇧^⋆ * y * w)⇧^⋆ * z ⊔ (x⇧^⋆ * y * w)⇧^⋆ * z"
    by (smt sup_commute mult_assoc star.circ_sup star.circ_loop_fixpoint)
  also have "... ≤ (x⇧^⋆ * y * w)⇧^⋆ * x⇧^ω ⊔ (x⇧^⋆ * y * w)⇧^⋆ * z"
    by (smt sup_commute sup_right_isotone mult_assoc mult_right_isotone omega_sub_vector)
  finally have "w * (x⇧^ω ⊔ x⇧^⋆ * y * w)⇧^⋆ * z ≤ (w * x⇧^⋆ * y)⇧^⋆ * w * x⇧^ω ⊔ (w * x⇧^⋆ * y)⇧^⋆ * w * z"
    by (metis mult_assoc mult_left_dist_sup mult_right_isotone star.circ_slide)
  hence "w * (x⇧^ω ⊔ x⇧^⋆ * y * w)⇧^ω ⊔ w * (x⇧^ω ⊔ x⇧^⋆ * y * w)⇧^⋆ * z ≤ (w * x⇧^⋆ * y)⇧^⋆ * (w * x⇧^ω)⇧^ω ⊔ (w * x⇧^⋆ * y)⇧^ω ⊔ (w * x⇧^⋆ * y)⇧^⋆ * w * z"
    using 1 by (smt sup_assoc sup_commute le_iff_sup mult_assoc tarski_mult_omega_omega)
  also have "... ≤ (w * x⇧^ω ⊔ w * x⇧^⋆ * y)⇧^⋆ * (w * x⇧^ω ⊔ w * x⇧^⋆ * y)⇧^ω ⊔ (w * x⇧^ω ⊔ w * x⇧^⋆ * y)⇧^ω ⊔ (w * x⇧^ω ⊔ w * x⇧^⋆ * y)⇧^⋆ * w * z"
    by (metis sup_mono sup_ge1 sup_ge2 mult_isotone mult_left_isotone omega_isotone star.circ_isotone)
  also have "... = (w * x⇧^ω ⊔ w * x⇧^⋆ * y)⇧^ω ⊔ (w * x⇧^ω ⊔ w * x⇧^⋆ * y)⇧^⋆ * w * z"
    by (simp add: star_mult_omega)
  finally have "w * ((x⇧^ω ⊔ x⇧^⋆ * y * w)⇧^ω ⊔ (x⇧^ω ⊔ x⇧^⋆ * y * w)⇧^⋆ * z) ≤ w * ((x⇧^ω ⊔ x⇧^⋆ * y) * w)⇧^ω ⊔ w * ((x⇧^ω ⊔ x⇧^⋆ * y) * w)⇧^⋆ * z"
    by (smt mult_assoc mult_left_dist_sup omega_slide star.circ_slide)
  hence 2: "w * ((x ⋆ (y * w)) ⋆ z) ≤ w * (((x ⋆ y) * w) ⋆ z)"
    by (simp add: mult_left_dist_sup while_def mult_assoc)
  have "w * (((x ⋆ y) * w) ⋆ z) ≤ w * ((x ⋆ (y * w)) ⋆ z)"
    by (simp add: mult_right_isotone while_left_isotone while_sub_associative)
  thus ?thesis
    using 2 order.antisym by auto
qed

lemma while_denest_3:
  "(x ⋆ w) ⋆ x⇧^ω = (x ⋆ w)⇧^ω"
proof -
  have 1: "(x ⋆ w) ⋆ x⇧^ω = (x ⋆ w)⇧^ω ⊔ (x ⋆ w)⇧^⋆ * x⇧^ω⇧^ω"
    by (simp add: while_def tarski_omega_idempotent)
  also have "... ≤ (x ⋆ w)⇧^ω ⊔ (x ⋆ w)⇧^⋆ * (x⇧^ω ⊔ x⇧^⋆ * w)⇧^ω"
    using mult_right_isotone omega_sub_dist semiring.add_left_mono by blast
  also have "... = (x ⋆ w)⇧^ω"
    by (simp add: star_mult_omega while_def)
  finally show ?thesis
    using 1 by (simp add: sup.order_iff)
qed

lemma while_denest_4a:
  "(x ⋆ w) ⋆ (x ⋆ (y * z)) = (x ⋆ w) ⋆ ((x ⋆ y) * z)"
proof -
  have "(x ⋆ w) ⋆ (x ⋆ (y * z)) = (x ⋆ w)⇧^ω ⊔ ((x ⋆ w) ⋆ (x⇧^⋆ * y * z))"
    using while_def while_denest_3 while_left_dist_sup mult_assoc by auto
  also have "... ≤ (x ⋆ w)⇧^ω ⊔ ((x ⋆ w) ⋆ ((x ⋆ y) * z))"
    using mult_right_sub_dist_sup_right order.refl semiring.add_mono while_def while_right_isotone by auto
  finally have 1: "(x ⋆ w) ⋆ (x ⋆ (y * z)) ≤ (x ⋆ w) ⋆ ((x ⋆ y) * z)"
    by (simp add: while_def)
  have "(x ⋆ w) ⋆ ((x ⋆ y) * z) ≤ (x ⋆ w) ⋆ (x ⋆ (y * z))"
    by (simp add: while_right_isotone while_sub_associative)
  thus ?thesis
    using 1 order.antisym by auto
qed

text ‹Theorem 8.3›

subclass bounded_extended_binary_itering
  apply unfold_locales
  by (smt mult_assoc while_denest_2a while_denest_4a while_increasing while_slide)

text ‹Theorem 13.13›

lemma while_mult_top:
  "(x * top) ⋆ z = z ⊔ x * top"
proof -
  have 1: "z ⊔ x * top ≤ (x * top) ⋆ z"
    by (metis le_supI sup_ge1 while_def while_increasing tarski_top_omega)
  have "(x * top) ⋆ z = z ⊔ x * top * ((x * top) ⋆ z)"
    using while_left_unfold by auto
  also have "... ≤ z ⊔ x * top"
    using mult_right_isotone sup_right_isotone top_greatest mult_assoc by auto
  finally show ?thesis
    using 1 order.antisym by auto
qed

lemma tarski_top_omega_below_2:
  "x * top ≤ (x * top) ⋆ bot"
  by (simp add: while_mult_top)

lemma tarski_top_omega_2:
  "x * top = (x * top) ⋆ bot"
  by (simp add: while_mult_top)

lemma tarski_below_top_omega_2:
  "x ≤ (x * top) ⋆ bot"
  using top_right_mult_increasing tarski_top_omega_2 by auto

(*
lemma "1 = (x * bot) ⋆ 1" nitpick [expect=genuine,card=3] oops
*)

end

class nonstrict_itering_tarski_zero = nonstrict_itering_tarski + nonstrict_itering_zero
begin

lemma while_bot_1:
  "1 = (x * bot) ⋆ 1"
  by (simp add: mult_right_zero while_zero)

text ‹Theorem 13 counterexamples›

(*
lemma while_associative: "(x ⋆ y) * z = x ⋆ (y * z)" nitpick [expect=genuine,card=2] oops
lemma "(x ⋆ 1) * y = x ⋆ y" nitpick [expect=genuine,card=2] oops
lemma while_one_mult: "(x ⋆ 1) * x = x ⋆ x" nitpick [expect=genuine,card=4] oops
lemma "(x ⊔ y) ⋆ z = ((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z)" nitpick [expect=genuine,card=2] oops
lemma while_mult_top_2: "(x * top) ⋆ z = z ⊔ x * top * z" nitpick [expect=genuine,card=2] oops
lemma while_top_2: "top ⋆ z = top * z" nitpick [expect=genuine,card=2] oops

lemma tarski: "x = bot ∨ top * x * top = top" nitpick [expect=genuine,card=3] oops
lemma while_back_loop_is_fixpoint: "is_fixpoint (λx . x * y ⊔ z) (z * (y ⋆ 1))" nitpick [expect=genuine,card=4] oops
lemma "1 ⊔ x * bot = x ⋆ 1" nitpick [expect=genuine,card=3] oops
lemma "x = x * (x ⋆ 1)" nitpick [expect=genuine,card=3] oops
lemma "x * (x ⋆ 1) = x ⋆ 1" nitpick [expect=genuine,card=2] oops
lemma "x ⋆ 1 = x ⋆ (1 ⋆ 1)" nitpick [expect=genuine,card=3] oops
lemma "(x ⊔ y) ⋆ 1 = (x ⋆ (y ⋆ 1)) ⋆ 1" nitpick [expect=genuine,card=3] oops
lemma "z ⊔ y * x = x ⟹ y ⋆ z ≤ x" nitpick [expect=genuine,card=2] oops
lemma "y * x = x ==> y ⋆ x ≤ x" nitpick [expect=genuine,card=2] oops
lemma "z ⊔ x * y = x ⟹ z * (y ⋆ 1) ≤ x" nitpick [expect=genuine,card=3] oops
lemma "x * y = x ⟹ x * (y ⋆ 1) ≤ x" nitpick [expect=genuine,card=3] oops
lemma "x * z = z * y ⟹ x ⋆ z ≤ z * (y ⋆ 1)" nitpick [expect=genuine,card=2] oops

lemma tarski: "x = bot ∨ top * x * top = top" nitpick [expect=genuine,card=3] oops
lemma tarski_case: assumes t1: "x = bot ⟶ P x" and t2: "top * x * top = top ⟶ P x" shows "P x" nitpick [expect=genuine,card=3] oops
*)

end

end

Theory Tests

(* Title:      Tests
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Tests›

theory Tests

imports Subset_Boolean_Algebras.Subset_Boolean_Algebras Base

begin

context subset_boolean_algebra_extended
begin

sublocale sba_dual: subset_boolean_algebra_extended where uminus = uminus and sup = inf and minus = "λx y . -(-x ⊓ y)" and inf = sup and bot = top and less_eq = greater_eq and less = greater and top = bot
  apply unfold_locales
  apply (simp add: inf_associative)
  apply (simp add: inf_commutative)
  using inf_cases_2 apply simp
  using inf_closed apply simp
  apply simp
  apply simp
  using sub_sup_closed sub_sup_demorgan apply simp
  apply simp
  apply (simp add: inf_commutative less_eq_inf)
  by (metis inf_commutative inf_idempotent inf_left_dist_sup sub_less_def sup_absorb sup_right_zero top_double_complement)

lemma strict_leq_def:
  "-x < -y ⟷ -x ≤ -y ∧ ¬ (-y ≤ -x)"
  by (simp add: sba_dual.sba_dual.sub_less_def sba_dual.sba_dual.sub_less_eq_def)

lemma one_def:
  "top = -bot"
  by simp

end

class tests = times + uminus + one + ord + sup + bot +
  assumes sub_assoc: "-x * (-y * -z) = (-x * -y) * -z"
  assumes sub_comm: "-x * -y = -y * -x"
  assumes sub_compl: "-x = -(--x * -y) * -(--x * --y)"
  assumes sub_mult_closed: "-x * -y = --(-x * -y)"
  assumes the_bot_def: "bot = (THE x . (∀y . x = -y * --y))" (* define without imposing uniqueness *)
  assumes one_def: "1 = - bot"
  assumes sup_def: "-x ⊔ -y = -(--x * --y)"
  assumes leq_def: "-x ≤ -y ⟷ -x * -y = -x"
  assumes strict_leq_def: "-x < -y ⟷ -x ≤ -y ∧ ¬ (-y ≤ -x)"
begin

sublocale tests_dual: subset_boolean_algebra_extended where uminus = uminus and sup = times and minus = "λx y . -(-x * y)" and inf = sup and bot = 1 and less_eq = greater_eq and less = greater and top = bot
  apply unfold_locales
  apply (simp add: sub_assoc)
  apply (simp add: sub_comm)
  apply (simp add: sub_compl)
  using sub_mult_closed apply simp
  apply (simp add: the_bot_def)
  apply (simp add: one_def the_bot_def)
  apply (simp add: sup_def)
  apply simp
  apply (simp add: leq_def sub_comm)
  by (simp add: leq_def strict_leq_def sub_comm)

sublocale sba: subset_boolean_algebra_extended where uminus = uminus and sup = sup and minus = "λx y . -(-x ⊔ y)" and inf = times and bot = bot and less_eq = less_eq and less = less and top = 1 ..

text ‹sets and sequences of tests›

definition test_set :: "'a set ⇒ bool"
  where "test_set A ≡ ∀x∈A . x = --x"

lemma mult_left_dist_test_set:
  "test_set A ⟹ test_set { -p * x | x . x ∈ A }"
  by (smt mem_Collect_eq sub_mult_closed test_set_def)

lemma mult_right_dist_test_set:
  "test_set A ⟹ test_set { x * -p | x . x ∈ A }"
  by (smt mem_Collect_eq sub_mult_closed test_set_def)

lemma sup_left_dist_test_set:
  "test_set A ⟹ test_set { -p ⊔ x | x . x ∈ A }"
  by (smt mem_Collect_eq tests_dual.sba_dual.sub_sup_closed test_set_def)

lemma sup_right_dist_test_set:
  "test_set A ⟹ test_set { x ⊔ -p | x . x ∈ A }"
  by (smt mem_Collect_eq tests_dual.sba_dual.sub_sup_closed test_set_def)

lemma test_set_closed:
  "A ⊆ B ⟹ test_set B ⟹ test_set A"
  using test_set_def by auto

definition test_seq :: "(nat ⇒ 'a) ⇒ bool"
  where "test_seq t ≡ ∀n . t n = --t n"

lemma test_seq_test_set:
  "test_seq t ⟹ test_set { t n | n::nat . True }"
  using test_seq_def test_set_def by auto

definition nat_test :: "(nat ⇒ 'a) ⇒ 'a ⇒ bool"
  where "nat_test t s ≡ (∀n . t n = --t n) ∧ s = --s ∧ (∀n . t n ≤ s) ∧ (∀x y . (∀n . t n * -x ≤ -y) ⟶ s * -x ≤ -y)"

lemma nat_test_seq:
  "nat_test t s ⟹ test_seq t"
  by (simp add: nat_test_def test_seq_def)

primrec pSum :: "(nat ⇒ 'a) ⇒ nat ⇒ 'a"
  where "pSum f 0 = bot"
      | "pSum f (Suc m) = pSum f m ⊔ f m"

lemma pSum_test:
  "test_seq t ⟹ pSum t m = --(pSum t m)"
  apply (induct m)
  apply simp
  by (smt pSum.simps(2) tests_dual.sba_dual.sub_sup_closed test_seq_def)

lemma pSum_test_nat:
  "nat_test t s ⟹ pSum t m = --(pSum t m)"
  by (metis nat_test_seq pSum_test)

lemma pSum_upper:
  "test_seq t ⟹ i<m ⟹ t i ≤ pSum t m"
proof (induct m)
  show "test_seq t ⟹ i<0 ⟹ t i ≤ pSum t 0"
    by (smt less_zeroE)
next
  fix n
  assume "test_seq t ⟹ i<n ⟹ t i ≤ pSum t n"
  hence "test_seq t ⟹ i<n ⟹ t i ≤ pSum t (Suc n)"
    by (smt (z3) pSum.simps(2) pSum_test tests_dual.sba_dual.upper_bound_left tests_dual.transitive test_seq_def)
  thus "test_seq t ⟹ i<Suc n ⟹ t i ≤ pSum t (Suc n)"
    by (metis less_Suc_eq pSum.simps(2) pSum_test tests_dual.sba_dual.upper_bound_right test_seq_def)
qed

lemma pSum_below:
  "test_seq t ⟹ (∀m<k . t m * -p ≤ -q) ⟹ pSum t k * -p ≤ -q"
  apply (induct k)
  apply (simp add: tests_dual.top_greatest)
  by (smt (verit, ccfv_threshold) tests_dual.sup_right_dist_inf pSum.simps(2) pSum_test test_seq_def sub_mult_closed less_Suc_eq tests_dual.sba_dual.sub_associative tests_dual.sba_dual.sub_less_eq_def)

lemma pSum_below_nat:
  "nat_test t s ⟹ (∀m<k . t m * -p ≤ -q) ⟹ pSum t k * -p ≤ -q"
  by (simp add: nat_test_seq pSum_below)

lemma pSum_below_sum:
  "nat_test t s ⟹ pSum t x ≤ s"
  by (smt (verit, ccfv_threshold) tests_dual.sup_right_unit nat_test_def one_def pSum_below_nat pSum_test_nat)

lemma ascending_chain_sup_left:
  "ascending_chain t ⟹ test_seq t ⟹ ascending_chain (λn . -p ⊔ t n) ∧ test_seq (λn . -p ⊔ t n)"
  by (smt (z3) ord.ascending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_right_isotone test_seq_def)

lemma ascending_chain_sup_right:
  "ascending_chain t ⟹ test_seq t ⟹ ascending_chain (λn . t n ⊔ -p) ∧ test_seq (λn . t n ⊔ -p)"
  by (smt ascending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_left_isotone test_seq_def)

lemma ascending_chain_mult_left:
  "ascending_chain t ⟹ test_seq t ⟹ ascending_chain (λn . -p * t n) ∧ test_seq (λn . -p * t n)"
  by (smt (z3) ascending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)

lemma ascending_chain_mult_right:
  "ascending_chain t ⟹ test_seq t ⟹ ascending_chain (λn . t n * -p) ∧ test_seq (λn . t n * -p)"
  by (smt (z3) ascending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)

lemma descending_chain_sup_left:
  "descending_chain t ⟹ test_seq t ⟹ descending_chain (λn . -p ⊔ t n) ∧ test_seq (λn . -p ⊔ t n)"
  by (smt descending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_right_isotone test_seq_def)

lemma descending_chain_sup_right:
  "descending_chain t ⟹ test_seq t ⟹ descending_chain (λn . t n ⊔ -p) ∧ test_seq (λn . t n ⊔ -p)"
  by (smt descending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_left_isotone test_seq_def)

lemma descending_chain_mult_left:
  "descending_chain t ⟹ test_seq t ⟹ descending_chain (λn . -p * t n) ∧ test_seq (λn . -p * t n)"
  by (smt (z3) descending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)

lemma descending_chain_mult_right:
  "descending_chain t ⟹ test_seq t ⟹ descending_chain (λn . t n * -p) ∧ test_seq (λn . t n * -p)"
  by (smt (z3) descending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)

end

end

Theory Test_Iterings

(* Title:      Test Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Test Iterings›

theory Test_Iterings

imports Stone_Kleene_Relation_Algebras.Iterings Tests

begin

class test_itering = itering + tests + while +
  assumes while_def: "p ⋆ y = (p * y)⇧^∘ * -p"
begin

lemma wnf_lemma_5:
  "(-p ⊔ -q) * (-q * x ⊔ --q * y) = -q * x ⊔ --q * -p * y"
  by (smt (z3) mult_left_dist_sup sup_commute tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sup_complement_intro tests_dual.sba_dual.sup_idempotent tests_dual.sup_idempotent mult_assoc tests_dual.wnf_lemma_3)

lemma test_case_split_left_equal:
  "-z * x = -z * y ⟹ --z * x = --z * y ⟹ x = y"
  by (metis case_split_left_equal tests_dual.inf_complement)

lemma preserves_equation:
  "-y * x ≤ x * -y ⟷ -y * x = -y * x * -y"
  apply (rule iffI)
  apply (simp add: test_preserves_equation tests_dual.sub_bot_least)
  by (simp add: test_preserves_equation tests_dual.sub_bot_least)

text ‹Theorem 5›

lemma preserve_test:
  "-y * x ≤ x * -y ⟹ -y * x⇧^∘ = -y * x⇧^∘ * -y"
  using circ_simulate preserves_equation by blast

text ‹Theorem 5›

lemma import_test:
  "-y * x ≤ x * -y ⟹ -y * x⇧^∘ = -y * (-y * x)⇧^∘"
  by (simp add: circ_import tests_dual.sub_bot_least)

definition ite :: "'a ⇒ 'a ⇒ 'a ⇒ 'a" ("_ ⊲ _ ⊳ _" [58,58,58] 57)
  where "x ⊲ p ⊳ y ≡ p * x ⊔ -p * y"

definition it :: "'a ⇒ 'a ⇒ 'a" ("_ ⊳ _" [58,58] 57)
  where "p ⊳ x ≡ p * x ⊔ -p"

(*
definition while :: "'a ⇒ 'a ⇒ 'a" (infixr "⋆" 59)
  where "p ⋆ y ≡ (p * y)⇧^∘ * -p"
*)

definition assigns :: "'a ⇒ 'a ⇒ 'a ⇒ bool"
  where "assigns x p q ≡ x = x * (p * q ⊔ -p * -q)"

definition preserves :: "'a ⇒ 'a ⇒ bool"
  where "preserves x p ≡ p * x ≤ x * p ∧ -p * x ≤ x * -p"

lemma ite_neg:
  "x ⊲ -p ⊳ y = y ⊲ --p ⊳ x"
  by (simp add: ite_def sup_commute)

lemma ite_import_true:
  "x ⊲ -p ⊳ y = -p * x ⊲ -p ⊳ y"
  by (metis ite_def tests_dual.sup_idempotent mult_assoc)

lemma ite_import_false:
  "x ⊲ -p ⊳ y = x ⊲ -p ⊳ --p * y"
  by (metis ite_import_true ite_neg)

lemma ite_import_true_false:
  "x ⊲ -p ⊳ y = -p * x ⊲ -p ⊳ --p * y"
  using ite_import_false ite_import_true by auto

lemma ite_context_true:
  "-p * (x ⊲ -p ⊳ y) = -p * x"
  by (metis sup_monoid.add_0_left tests_dual.sup_right_zero tests_dual.top_double_complement wnf_lemma_5 sup_bot_right ite_def mult_assoc mult_left_zero)

lemma ite_context_false:
  "--p * (x ⊲ -p ⊳ y) = --p * y"
  by (metis ite_neg ite_context_true)

lemma ite_context_import:
  "-p * (x ⊲ -q ⊳ y) = -p * (x ⊲ -p * -q ⊳ y)"
  by (smt ite_def mult_assoc tests_dual.sup_complement_intro tests_dual.sub_sup_demorgan tests_dual.sup_idempotent mult_left_dist_sup)

lemma ite_conjunction:
  "(x ⊲ -q ⊳ y) ⊲ -p ⊳ y = x ⊲ -p * -q ⊳ y"
  by (smt sup_assoc sup_commute ite_def mult_assoc tests_dual.sub_sup_demorgan mult_left_dist_sup mult_right_dist_sup tests_dual.inf_complement_intro)

lemma ite_disjunction:
  "x ⊲ -p ⊳ (x ⊲ -q ⊳ y) = x ⊲ -p ⊔ -q ⊳ y"
  by (smt (z3) tests_dual.sba_dual.sub_sup_closed sup_assoc ite_def mult_assoc tests_dual.sup_complement_intro tests_dual.sub_sup_demorgan mult_left_dist_sup mult_right_dist_sup tests_dual.inf_demorgan)

lemma wnf_lemma_6:
  "(-p ⊔ -q) * (x ⊲ --p * -q ⊳ y) = (-p ⊔ -q) * (y ⊲ -p ⊳ x)"
  by (smt (z3) ite_conjunction ite_context_false ite_context_true semiring.distrib_right tests_dual.sba_dual.inf_cases_2 tests_dual.sba_dual.sub_inf_def tests_dual.sba_dual.sup_complement_intro tests_dual.sub_complement)

lemma it_ite:
  "-p ⊳ x = x ⊲ -p ⊳ 1"
  by (simp add: it_def ite_def)

lemma it_neg:
  "--p ⊳ x = 1 ⊲ -p ⊳ x"
  using it_ite ite_neg by auto

lemma it_import_true:
  "-p ⊳ x = -p ⊳ -p * x"
  using it_ite ite_import_true by auto

lemma it_context_true:
  "-p * (-p ⊳ x) = -p * x"
  by (simp add: it_ite ite_context_true)

lemma it_context_false:
  "--p * (-p ⊳ x) = --p"
  using it_ite ite_context_false by force

lemma while_unfold_it:
  "-p ⋆ x = -p ⊳ x * (-p ⋆ x)"
  by (metis circ_loop_fixpoint it_def mult_assoc while_def)

lemma while_context_false:
  "--p * (-p ⋆ x) = --p"
  by (metis it_context_false while_unfold_it)

lemma while_context_true:
  "-p * (-p ⋆ x) = -p * x * (-p ⋆ x)"
  by (metis it_context_true mult_assoc while_unfold_it)

lemma while_zero:
  "bot ⋆ x = 1"
  by (metis circ_zero mult_left_one mult_left_zero one_def while_def)

lemma wnf_lemma_7:
  "1 * (bot ⋆ 1) = 1"
  by (simp add: while_zero)

lemma while_import_condition:
  "-p ⋆ x = -p ⋆ -p * x"
  by (metis mult_assoc tests_dual.sup_idempotent while_def)

lemma while_import_condition_2:
  "-p * -q ⋆ x = -p * -q ⋆ -p * x"
  by (metis mult_assoc tests_dual.sup_idempotent sub_comm while_def)

lemma wnf_lemma_8:
  "-r * (-p ⊔ --p * -q) ⋆ (x ⊲ --p * -q ⊳ y) = -r * (-p ⊔ -q) ⋆ (y ⊲ -p ⊳ x)"
  by (metis mult_assoc while_def wnf_lemma_6 tests_dual.sba_dual.sup_complement_intro)

text ‹Theorem 6 - see Theorem 31 on page 329 of Back and von Wright, Acta Informatica 36:295-334, 1999›

lemma split_merge_loops:
  assumes "--p * y ≤ y * --p"
    shows "(-p ⊔ -q) ⋆ (x ⊲ -p ⊳ y) = (-p ⋆ x) * (-q ⋆ y)"
proof -
  have "-p ⊔ -q ⋆ (x ⊲ -p ⊳ y) = (-p * x ⊔ --p * -q * y)⇧^∘ * --p * --q"
    by (smt ite_def mult_assoc sup_commute tests_dual.inf_demorgan while_def wnf_lemma_5)
  thus ?thesis
    by (smt assms circ_sup_1 circ_slide import_test mult_assoc preserves_equation sub_comm while_context_false while_def)
qed

lemma assigns_same:
  "assigns x (-p) (-p)"
  by (simp add: assigns_def)

lemma preserves_equation_test:
  "preserves x (-p) ⟷ -p * x = -p * x * -p ∧ --p * x = --p * x * --p"
  using preserves_def preserves_equation by auto

lemma preserves_test:
  "preserves (-q) (-p)"
  using tests_dual.sub_commutative preserves_def by auto

lemma preserves_zero:
  "preserves bot (-p)"
  using tests_dual.sba_dual.sub_bot_def preserves_test by blast

lemma preserves_one:
  "preserves 1 (-p)"
  using preserves_def by force

lemma preserves_sup:
  "preserves x (-p) ⟹ preserves y (-p) ⟹ preserves (x ⊔ y) (-p)"
  by (simp add: mult_left_dist_sup mult_right_dist_sup preserves_equation_test)

lemma preserves_mult:
  "preserves x (-p) ⟹ preserves y (-p) ⟹ preserves (x * y) (-p)"
  by (smt (verit, best) mult_assoc preserves_equation_test)

lemma preserves_ite:
  "preserves x (-p) ⟹ preserves y (-p) ⟹ preserves (x ⊲ -q ⊳ y) (-p)"
  by (simp add: ite_def preserves_mult preserves_sup preserves_test)

lemma preserves_it:
  "preserves x (-p) ⟹ preserves (-q ⊳ x) (-p)"
  by (simp add: it_ite preserves_ite preserves_one)

lemma preserves_circ:
  "preserves x (-p) ⟹ preserves (x⇧^∘) (-p)"
  by (meson circ_simulate preserves_def)

lemma preserves_while:
  "preserves x (-p) ⟹ preserves (-q ⋆ x) (-p)"
  using while_def preserves_circ preserves_mult preserves_test by auto

lemma preserves_test_neg:
  "preserves x (-p) ⟹ preserves x (--p)"
  using preserves_def by auto

lemma preserves_import_circ:
  "preserves x (-p) ⟹ -p * x⇧^∘ = -p * (-p * x)⇧^∘"
  using import_test preserves_def by blast

lemma preserves_simulate:
  "preserves x (-p) ⟹ -p * x⇧^∘ = -p * x⇧^∘ * -p"
  using preserve_test preserves_def by auto

lemma preserves_import_ite:
  assumes "preserves z (-p)"
    shows "z * (x ⊲ -p ⊳ y) = z * x ⊲ -p ⊳ z * y"
proof -
  have 1: "-p * z * (x ⊲ -p ⊳ y) = -p * (z * x ⊲ -p ⊳ z * y)"
    by (smt assms ite_context_true mult_assoc preserves_equation_test)
  have "--p * z * (x ⊲ -p ⊳ y) = --p * (z * x ⊲ -p ⊳ z * y)"
    by (smt (z3) assms ite_context_false mult_assoc preserves_equation_test)
  thus ?thesis
    using 1 by (metis mult_assoc test_case_split_left_equal)
qed

lemma preserves_while_context:
  "preserves x (-p) ⟹ -p * (-q ⋆ x) = -p * (-p * -q ⋆ x)"
  by (smt (verit, del_insts) mult_assoc tests_dual.sup_complement_intro tests_dual.sub_sup_demorgan preserves_import_circ preserves_mult preserves_simulate preserves_test while_def)

lemma while_ite_context_false:
  assumes "preserves y (-p)"
    shows "--p * (-p ⊔ -q ⋆ (x ⊲ -p ⊳ y)) = --p * (-q ⋆ y)"
proof -
  have "--p * (-p ⊔ -q ⋆ (x ⊲ -p ⊳ y)) = --p * (--p * -q * y)⇧^∘ * -(-p ⊔ -q)"
    by (smt (z3) assms import_test mult_assoc preserves_equation preserves_equation_test sub_comm while_def tests_dual.sba_dual.sub_sup_demorgan preserves_test split_merge_loops while_context_false)
  thus ?thesis
    by (metis (no_types, lifting) assms preserves_def mult.assoc split_merge_loops while_context_false)
qed

text ‹Theorem 7.1›

lemma while_ite_norm:
  assumes "assigns z (-p) (-q)"
      and "preserves x1 (-q)"
      and "preserves x2 (-q)"
      and "preserves y1 (-q)"
      and "preserves y2 (-q)"
    shows "z * (x1 * (-r1 ⋆ y1) ⊲ -p ⊳ x2 * (-r2 ⋆ y2)) = z * (x1 ⊲ -q ⊳ x2) * ((-q * -r1 ⊔ --q * -r2) ⋆ (y1 ⊲ -q ⊳ y2))"
proof -
  have 1: "-(-q * -r1 ⊔ --q * -r2) = -q * --r1 ⊔ --q * --r2"
    by (smt (z3) tests_dual.complement_2 tests_dual.sub_sup_closed tests_dual.case_duality tests_dual.sub_sup_demorgan)
  have "-p * -q * x1 * (-q * -r1 * y1 ⊔ --q * -r2 * y2)⇧^∘ * (-q * --r1 ⊔ --q * --r2) = -p * -q * x1 * -q * (-q * (-q * -r1 * y1 ⊔ --q * -r2 * y2))⇧^∘ * (-q * --r1 ⊔ --q * --r2)"
    by (smt (verit, del_insts) assms(2,4,5) mult_assoc preserves_sup preserves_equation_test preserves_import_circ preserves_mult preserves_test)
  also have "... = -p * -q * x1 * -q * (-q * -r1 * y1)⇧^∘ * (-q * --r1 ⊔ --q * --r2)"
    using ite_context_true ite_def mult_assoc by auto
  finally have 2: "-p * -q * x1 * (-q * -r1 * y1 ⊔ --q * -r2 * y2)⇧^∘ * (-q * --r1 ⊔ --q * --r2) = -p * -q * x1 * (-r1 * y1)⇧^∘ * --r1"
    by (smt (verit, del_insts) assms ite_context_true ite_def mult_assoc preserves_equation_test preserves_import_circ preserves_mult preserves_simulate preserves_test)
  have "--p * --q * x2 * (-q * -r1 * y1 ⊔ --q * -r2 * y2)⇧^∘ * (-q * --r1 ⊔ --q * --r2) = --p * --q * x2 * --q * (--q * (-q * -r1 * y1 ⊔ --q * -r2 * y2))⇧^∘ * (-q * --r1 ⊔ --q * --r2)"
    by (smt (verit, del_insts) assms mult_assoc preserves_sup preserves_equation_test preserves_import_circ preserves_mult preserves_test preserves_test_neg)
  also have "... = --p * --q * x2 * --q * (--q * -r2 * y2)⇧^∘ * (-q * --r1 ⊔ --q * --r2)"
    using ite_context_false ite_def mult_assoc by auto
  finally have "--p * --q * x2 * (-q * -r1 * y1 ⊔ --q * -r2 * y2)⇧^∘ * (-q * --r1 ⊔ --q * --r2) = --p * --q * x2 * (-r2 * y2)⇧^∘ * --r2"
    by (smt (verit, del_insts) assms(3,5) ite_context_false ite_def mult_assoc preserves_equation_test preserves_import_circ preserves_mult preserves_simulate preserves_test preserves_test_neg)
  thus ?thesis
    using 1 2 by (smt (z3) assms(1) assigns_def mult_assoc mult_right_dist_sup while_def ite_context_false ite_context_true tests_dual.sub_commutative)
qed

lemma while_it_norm:
  "assigns z (-p) (-q) ⟹ preserves x (-q) ⟹ preserves y (-q) ⟹ z * (-p ⊳ x * (-r ⋆ y)) = z * (-q ⊳ x) * (-q * -r ⋆ y)"
  by (metis sup_bot_right tests_dual.sup_right_zero it_context_true it_ite tests_dual.complement_bot preserves_one while_import_condition_2 while_ite_norm wnf_lemma_7)

lemma while_else_norm:
  "assigns z (-p) (-q) ⟹ preserves x (-q) ⟹ preserves y (-q) ⟹ z * (1 ⊲ -p ⊳ x * (-r ⋆ y)) = z * (1 ⊲ -q ⊳ x) * (--q * -r ⋆ y)"
  by (metis sup_bot_left tests_dual.sup_right_zero ite_context_false tests_dual.complement_bot preserves_one while_import_condition_2 while_ite_norm wnf_lemma_7)

lemma while_while_pre_norm:
  "-p ⋆ x * (-q ⋆ y) = -p ⊳ x * (-p ⊔ -q ⋆ (y ⊲ -q ⊳ x))"
  by (smt sup_commute circ_sup_1 circ_left_unfold circ_slide it_def ite_def mult_assoc mult_left_one mult_right_dist_sup tests_dual.inf_demorgan while_def wnf_lemma_5)

text ‹Theorem 7.2›

lemma while_while_norm:
  "assigns z (-p) (-r) ⟹ preserves x (-r) ⟹ preserves y (-r) ⟹ z * (-p ⋆ x * (-q ⋆ y)) = z * (-r ⊳ x) * (-r * (-p ⊔ -q) ⋆ (y ⊲ -q ⊳ x))"
  by (smt tests_dual.double_negation tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_ite while_it_norm while_while_pre_norm)

lemma while_seq_replace:
  "assigns z (-p) (-q) ⟹ z * (-p ⋆ x * z) * y = z * (-q ⋆ x * z) * y"
  by (smt assigns_def circ_slide mult_assoc tests_dual.wnf_lemma_1 tests_dual.wnf_lemma_2 tests_dual.wnf_lemma_3 tests_dual.wnf_lemma_4 while_def)

lemma while_ite_replace:
  "assigns z (-p) (-q) ⟹ z * (x ⊲ -p ⊳ y) = z * (x ⊲ -q ⊳ y)"
  by (smt assigns_def ite_def mult_assoc mult_left_dist_sup sub_comm tests_dual.wnf_lemma_1 tests_dual.wnf_lemma_3)

lemma while_post_norm_an:
  assumes "preserves y (-p)"
    shows "(-p ⋆ x) * y = y ⊲ --p ⊳ (-p ⋆ x * (--p ⊳ y))"
proof -
  have "-p * (-p * x * (--p * y ⊔ -p))⇧^∘ * --p = -p * x * ((--p * y ⊔ -p) * -p * x)⇧^∘ * (--p * y ⊔ -p) * --p"
    by (metis circ_slide_1 while_def mult_assoc while_context_true)
  also have "... = -p * x * (--p * y * bot ⊔ -p * x)⇧^∘ * --p * y"
    by (smt assms sup_bot_right mult_assoc tests_dual.sup_complement tests_dual.sup_idempotent mult_left_zero mult_right_dist_sup preserves_equation_test sub_comm)
  finally have "-p * (-p * x * (--p * y ⊔ -p))⇧^∘ * --p = -p * x * (-p * x)⇧^∘ * --p * y"
    by (metis circ_sup_mult_zero sup_commute mult_assoc)
  thus ?thesis
    by (smt circ_left_unfold tests_dual.double_negation it_def ite_def mult_assoc mult_left_one mult_right_dist_sup while_def)
qed

lemma while_post_norm:
  "preserves y (-p) ⟹ (-p ⋆ x) * y = -p ⋆ x * (1 ⊲ -p ⊳ y) ⊲ -p ⊳ y"
  using it_neg ite_neg while_post_norm_an by force

lemma wnf_lemma_9:
  assumes "assigns z (-p) (-q)"
      and "preserves x1 (-q)"
      and "preserves y1 (-q)"
      and "preserves x2 (-q)"
      and "preserves y2 (-q)"
      and "preserves x2 (-p)"
      and "preserves y2 (-p)"
    shows "z * (x1 ⊲ -q ⊳ x2) * (-q * -p ⊔ -r ⋆ (y1 ⊲ -q * -p ⊳ y2)) = z * (x1 ⊲ -p ⊳ x2) * (-p ⊔ -r ⋆ (y1 ⊲ -p ⊳ y2))"
proof -
  have "z * --p * --q * (x1 ⊲ -q ⊳ x2) * (-q * -p ⊔ -r ⋆ (y1 ⊲ -q * -p ⊳ y2)) = z * --p * --q * x2 * --q * (--q * (-q * -p ⊔ -r) ⋆ (y1 ⊲ -q * -p ⊳ y2))"
    by (smt (verit, del_insts) assms(3-5) tests_dual.double_negation ite_context_false mult_assoc tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_equation_test preserves_ite preserves_while_context)
  also have "... = z * --p * --q * x2 * --q * (--q * -r ⋆ --q * y2)"
    by (smt sup_bot_left tests_dual.double_negation ite_conjunction ite_context_false mult_assoc tests_dual.sup_complement mult_left_dist_sup mult_left_zero while_import_condition_2)
  also have "... = z * --p * --q * x2 * (-r ⋆ y2)"
    by (metis assms(4,5) mult_assoc preserves_equation_test preserves_test_neg preserves_while_context while_import_condition_2)
  finally have 1: "z * --p * --q * (x1 ⊲ -q ⊳ x2) * (-q * -p ⊔ -r ⋆ (y1 ⊲ -q * -p ⊳ y2)) = z * --p * --q * (x1 ⊲ -q ⊳ x2) * (-p ⊔ -r ⋆ (y1 ⊲ -p ⊳ y2))"
    by (smt assms(6,7) ite_context_false mult_assoc preserves_equation_test sub_comm while_ite_context_false)
  have "z * -p * -q * (x1 ⊲ -q ⊳ x2) * (-q * -p ⊔ -r ⋆ (y1 ⊲ -q * -p ⊳ y2)) = z * -p * -q * (x1 ⊲ -q ⊳ x2) * -q * (-q * (-p ⊔ -r) ⋆ -q * (y1 ⊲ -p ⊳ y2))"
    by (smt (verit, del_insts) assms(2-5) tests_dual.double_negation ite_context_import mult_assoc tests_dual.sub_sup_demorgan tests_dual.sup_idempotent mult_left_dist_sup tests_dual.inf_demorgan preserves_equation_test preserves_ite preserves_while_context while_import_condition_2)
  hence "z * -p * -q * (x1 ⊲ -q ⊳ x2) * (-q * -p ⊔ -r ⋆ (y1 ⊲ -q * -p ⊳ y2)) = z * -p * -q * (x1 ⊲ -q ⊳ x2) * (-p ⊔ -r ⋆ (y1 ⊲ -p ⊳ y2))"
    by (smt assms(2-5) tests_dual.double_negation mult_assoc tests_dual.sub_sup_demorgan tests_dual.sup_idempotent preserves_equation_test preserves_ite preserves_while_context while_import_condition_2)
  thus ?thesis
    using 1 by (smt assms(1) assigns_def mult_assoc mult_left_dist_sup mult_right_dist_sup while_ite_replace)
qed

text ‹Theorem 7.3›

lemma while_seq_norm:
  assumes "assigns z1 (-r1) (-q)"
      and "preserves x2 (-q)"
      and "preserves y2 (-q)"
      and "preserves z2 (-q)"
      and "z1 * z2 = z2 * z1"
      and "assigns z2 (-q) (-r)"
      and "preserves y1 (-r)"
      and "preserves z1 (-r)"
      and "preserves x2 (-r)"
      and "preserves y2 (-r)"
    shows "x1 * z1 * z2 * (-r1 ⋆ y1 * z1) * x2 * (-r2 ⋆ y2) = x1 * z1 * z2 * (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ x2) * (-q ⊔ -r2 ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2))"
proof -
  have 1: "preserves (y1 * z1 * (1 ⊲ -q ⊳ x2)) (-r)"
    by (simp add: assms(7-9) ite_def preserves_mult preserves_sup preserves_test)
  hence 2: "preserves (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2) (-r)"
    by (simp add: assms(10) preserves_ite)
  have "x1 * z1 * z2 * (-r1 ⋆ y1 * z1) * x2 * (-r2 ⋆ y2) = x1 * z1 * z2 * (-q ⋆ y1 * z1) * x2 * (-r2 ⋆ y2)"
    using assms(1,5) mult_assoc while_seq_replace by auto
  also have "... = x1 * z1 * z2 * (-q ⋆ y1 * z1 * (1 ⊲ -q ⊳ x2 * (-r2 ⋆ y2)) ⊲ -q ⊳ x2 * (-r2 ⋆ y2))"
    by (smt assms(2,3) mult_assoc preserves_mult preserves_while while_post_norm)
  also have "... = x1 * z1 * (z2 * (-q ⋆ y1 * z1 * (1 ⊲ -q ⊳ x2) * (--q * -r2 ⋆ y2)) ⊲ -q ⊳ z2 * x2 * (-r2 ⋆ y2))"
    by (smt assms(2-4) assigns_same mult_assoc preserves_import_ite while_else_norm)
  also have "... = x1 * z1 * (z2 * (-r ⊳ y1 * z1 * (1 ⊲ -q ⊳ x2)) * (-r * (-q ⊔ -r2) ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2)) ⊲ -q ⊳ z2 * x2 * (-r2 ⋆ y2))"
    by (smt assms(6-10) tests_dual.double_negation tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_ite preserves_mult preserves_one while_while_norm wnf_lemma_8)
  also have "... = x1 * z1 * z2 * ((-r ⊳ y1 * z1 * (1 ⊲ -q ⊳ x2)) * (-r * (-q ⊔ -r2) ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2)) ⊲ -r ⊳ x2 * (-r2 ⋆ y2))"
    by (smt assms(4,6) mult_assoc preserves_import_ite while_ite_replace)
  also have "... = x1 * z1 * z2 * (-r * (y1 * z1 * (1 ⊲ -q ⊳ x2)) * (-r * (-q ⊔ -r2) ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2)) ⊲ -r ⊳ x2 * (-r2 ⋆ y2))"
    by (smt mult_assoc it_context_true ite_import_true)
  also have "... = x1 * z1 * z2 * (-r * (y1 * z1 * (1 ⊲ -q ⊳ x2)) * -r * (-r * (-q ⊔ -r2) ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2)) ⊲ -r ⊳ x2 * (-r2 ⋆ y2))"
    using 1 by (simp add: preserves_equation_test)
  also have "... = x1 * z1 * z2 * (-r * (y1 * z1 * (1 ⊲ -q ⊳ x2)) * -r * (-q ⊔ -r2 ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2)) ⊲ -r ⊳ x2 * (-r2 ⋆ y2))"
    using 2 by (smt (z3) tests_dual.sba_dual.sub_sup_closed mult_assoc preserves_while_context)
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1 ⊲ -q ⊳ x2) * (-q ⊔ -r2 ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2)) ⊲ -q ⊳ x2 * (-r2 ⋆ y2))"
    by (smt assms(6-9) tests_dual.double_negation ite_import_true mult_assoc tests_dual.sup_idempotent preserves_equation_test preserves_ite preserves_one while_ite_replace)
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -r ⊳ x2) * ((-r * (-q ⊔ -r2) ⊔ --r * -r2) ⋆ ((y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2) ⊲ -r ⊳ y2))"
    by (smt assms(6-10) tests_dual.double_negation mult_assoc tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_ite preserves_mult preserves_one while_ite_norm)
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -r ⊳ x2) * ((-r * (-q ⊔ -r2) ⊔ --r * -r2) ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -r * -q ⊳ y2))"
    using ite_conjunction by simp
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -r ⊳ x2) * ((-r * -q ⊔ -r2) ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -r * -q ⊳ y2))"
    by (smt (z3) mult_left_dist_sup sup_assoc tests_dual.sba_dual.sup_cases tests_dual.sub_commutative)
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ x2) * (-q ⊔ -r2 ⋆ (y1 * z1 * (1 ⊲ -q ⊳ x2) ⊲ -q ⊳ y2))"
    using 1 by (metis assms(2,3,6,9,10) mult_assoc wnf_lemma_9)
  finally show ?thesis
    .
qed

end

end

Theory N_Semirings

(* Title:      N-Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹N-Semirings›

theory N_Semirings

imports Test_Iterings Omega_Algebras

begin

class n_semiring = bounded_idempotent_left_zero_semiring + n + L +
  assumes n_bot         : "n(bot) = bot"
  assumes n_top         : "n(top) = 1"
  assumes n_dist_sup    : "n(x ⊔ y) = n(x) ⊔ n(y)"
  assumes n_export      : "n(n(x) * y) = n(x) * n(y)"
  assumes n_sub_mult_bot: "n(x) = n(x * bot) * n(x)"
  assumes n_L_split     : "x * n(y) * L = x * bot ⊔ n(x * y) * L"
  assumes n_split       : "x ≤ x * bot ⊔ n(x * L) * top"
begin

lemma n_sub_one:
  "n(x) ≤ 1"
  by (metis sup_left_top sup_ge2 n_dist_sup n_top)

text ‹Theorem 15›

lemma n_isotone:
  "x ≤ y ⟹ n(x) ≤ n(y)"
  by (metis le_iff_sup n_dist_sup)

lemma n_mult_idempotent:
  "n(x) * n(x) = n(x)"
  by (metis mult_assoc mult_1_right n_export n_sub_mult_bot n_top)

text ‹Theorem 15.3›

lemma n_mult_bot:
  "n(x) = n(x * bot)"
  by (metis sup_commute sup_left_top sup_bot_right mult_left_dist_sup mult_1_right n_dist_sup n_sub_mult_bot n_top)

lemma n_mult_left_upper_bound:
  "n(x) ≤ n(x * y)"
  by (metis mult_right_isotone n_isotone n_mult_bot bot_least)

lemma n_mult_right_bot:
  "n(x) * bot = bot"
  by (metis sup_left_top sup_bot_left mult_left_one mult_1_right n_export n_dist_sup n_sub_mult_bot n_top n_bot)

text ‹Theorem 15.9›

lemma n_mult_n:
  "n(x * n(y)) = n(x)"
  by (metis mult_assoc n_mult_right_bot n_mult_bot)

lemma n_mult_left_absorb_sup:
  "n(x) * (n(x) ⊔ n(y)) = n(x)"
  by (metis sup_left_top mult_left_dist_sup mult_1_right n_dist_sup n_mult_idempotent n_top)

lemma n_mult_right_absorb_sup:
  "(n(x) ⊔ n(y)) * n(y) = n(y)"
  by (metis sup_commute sup_left_top mult_left_one mult_right_dist_sup n_dist_sup n_mult_idempotent n_top)

lemma n_sup_left_absorb_mult:
  "n(x) ⊔ n(x) * n(y) = n(x)"
  using mult_left_dist_sup n_mult_idempotent n_mult_left_absorb_sup by auto

lemma n_sup_right_absorb_mult:
  "n(x) * n(y) ⊔ n(y) = n(y)"
  using mult_right_dist_sup n_mult_idempotent n_mult_right_absorb_sup by auto

lemma n_mult_commutative:
  "n(x) * n(y) = n(y) * n(x)"
  by (smt sup_commute mult_left_dist_sup mult_right_dist_sup n_sup_left_absorb_mult n_sup_right_absorb_mult n_export n_mult_idempotent)

lemma n_sup_left_dist_mult:
  "n(x) ⊔ n(y) * n(z) = (n(x) ⊔ n(y)) * (n(x) ⊔ n(z))"
  by (metis sup_assoc mult_left_dist_sup mult_right_dist_sup n_sup_right_absorb_mult n_mult_commutative n_mult_left_absorb_sup)

lemma n_sup_right_dist_mult:
  "n(x) * n(y) ⊔ n(z) = (n(x) ⊔ n(z)) * (n(y) ⊔ n(z))"
  by (simp add: sup_commute n_sup_left_dist_mult)

lemma n_order:
  "n(x) ≤ n(y) ⟷ n(x) * n(y) = n(x)"
  by (metis le_iff_sup n_sup_right_absorb_mult n_mult_left_absorb_sup)

lemma n_mult_left_lower_bound:
  "n(x) * n(y) ≤ n(x)"
  by (simp add: sup.orderI n_sup_left_absorb_mult)

lemma n_mult_right_lower_bound:
  "n(x) * n(y) ≤ n(y)"
  by (simp add: le_iff_sup n_sup_right_absorb_mult)

lemma n_mult_least_upper_bound:
  "n(x) ≤ n(y) ∧ n(x) ≤ n(z) ⟷ n(x) ≤ n(y) * n(z)"
  by (metis order.trans mult_left_isotone n_mult_commutative n_mult_right_lower_bound n_order)

lemma n_mult_left_divisibility:
  "n(x) ≤ n(y) ⟷ (∃z . n(x) = n(y) * n(z))"
  by (metis n_mult_commutative n_mult_left_lower_bound n_order)

lemma n_mult_right_divisibility:
  "n(x) ≤ n(y) ⟷ (∃z . n(x) = n(z) * n(y))"
  by (simp add: n_mult_commutative n_mult_left_divisibility)

text ‹Theorem 15.1›

lemma n_one:
  "n(1) = bot"
  by (metis mult_left_one n_mult_bot n_bot)

lemma n_split_equal:
  "x ⊔ n(x * L) * top = x * bot ⊔ n(x * L) * top"
  using n_split order_trans sup.cobounded1 sup_same_context zero_right_mult_decreasing by blast

lemma n_split_top:
  "x * top ≤ x * bot ⊔ n(x * L) * top"
  by (metis mult_left_isotone n_split vector_bot_closed vector_mult_closed vector_sup_closed vector_top_closed)

text ‹Theorem 15.2›

lemma n_L:
  "n(L) = 1"
  by (metis sup_bot_left order.antisym mult_left_one n_export n_isotone n_mult_commutative n_split_top n_sub_one n_top)

text ‹Theorem 15.5›

lemma n_split_L:
  "x * L = x * bot ⊔ n(x * L) * L"
  by (metis mult_1_right n_L n_L_split)

lemma n_n_L:
  "n(n(x) * L) = n(x)"
  by (simp add: n_export n_L)

lemma n_L_decreasing:
  "n(x) * L ≤ x"
  by (metis mult_left_zero n_L_split order_trans sup.orderI zero_right_mult_decreasing mult_assoc n_mult_bot)

text ‹Theorem 15.10›

lemma n_galois:
  "n(x) ≤ n(y) ⟷ n(x) * L ≤ y"
  by (metis order.trans mult_left_isotone n_L_decreasing n_isotone n_n_L)

text ‹Theorem 15.6›

lemma split_L:
  "x * L ≤ x * bot ⊔ L"
  by (metis sup_commute sup_left_isotone n_galois n_L n_split_L n_sub_one)

text ‹Theorem 15.7›

lemma L_left_zero:
  "L * x = L"
  by (metis order.antisym mult.left_neutral mult_left_zero zero_right_mult_decreasing n_L n_L_decreasing n_mult_bot mult.assoc)

text ‹Theorem 15.8›

lemma n_mult:
  "n(x * n(y) * L) = n(x * y)"
  using n_L_split n_dist_sup sup.absorb2 n_mult_left_upper_bound n_mult_bot n_n_L by auto

lemma n_mult_top:
  "n(x * n(y) * top) = n(x * y)"
  by (metis mult_1_right n_mult n_top)

text ‹Theorem 15.4›

lemma n_top_L:
  "n(x * top) = n(x * L)"
  by (metis mult_1_right n_L n_mult_top)

lemma n_top_split:
  "x * n(y) * top ≤ x * bot ⊔ n(x * y) * top"
  by (metis mult_assoc n_mult n_mult_right_bot n_split_top)

lemma n_mult_right_upper_bound:
  "n(x * y) ≤ n(z) ⟷ n(x) ≤ n(z) ∧ x * n(y) * L ≤ x * bot ⊔ n(z) * L"
  apply (rule iffI)
  apply (metis sup_right_isotone order.eq_iff mult_isotone n_L_split n_mult_left_upper_bound order_trans)
  by (smt (verit, ccfv_threshold) n_dist_sup n_export sup.absorb_iff2 n_mult n_mult_commutative n_mult_bot n_n_L)

lemma n_preserves_equation:
  "n(y) * x ≤ x * n(y) ⟷ n(y) * x = n(y) * x * n(y)"
  using eq_refl test_preserves_equation n_mult_idempotent n_sub_one by auto

definition ni :: "'a ⇒ 'a"
  where "ni x = n(x) * L"

lemma ni_bot:
  "ni(bot) = bot"
  by (simp add: n_bot ni_def)

lemma ni_one:
  "ni(1) = bot"
  by (simp add: n_one ni_def)

lemma ni_L:
  "ni(L) = L"
  by (simp add: n_L ni_def)

lemma ni_top:
  "ni(top) = L"
  by (simp add: n_top ni_def)

lemma ni_dist_sup:
  "ni(x ⊔ y) = ni(x) ⊔ ni(y)"
  by (simp add: mult_right_dist_sup n_dist_sup ni_def)

lemma ni_mult_bot:
  "ni(x) = ni(x * bot)"
  using n_mult_bot ni_def by auto

lemma ni_split:
  "x * ni(y) = x * bot ⊔ ni(x * y)"
  using n_L_split mult_assoc ni_def by auto

lemma ni_decreasing:
  "ni(x) ≤ x"
  by (simp add: n_L_decreasing ni_def)

lemma ni_isotone:
  "x ≤ y ⟹ ni(x) ≤ ni(y)"
  using mult_left_isotone n_isotone ni_def by auto

lemma ni_mult_left_upper_bound:
  "ni(x) ≤ ni(x * y)"
  using mult_left_isotone n_mult_left_upper_bound ni_def by force

lemma ni_idempotent:
  "ni(ni(x)) = ni(x)"
  by (simp add: n_n_L ni_def)

lemma ni_below_L:
  "ni(x) ≤ L"
  using n_L n_galois n_sub_one ni_def by auto

lemma ni_left_zero:
  "ni(x) * y = ni(x)"
  by (simp add: L_left_zero mult_assoc ni_def)

lemma ni_split_L:
  "x * L = x * bot ⊔ ni(x * L)"
  using n_split_L ni_def by auto

lemma ni_top_L:
  "ni(x * top) = ni(x * L)"
  by (simp add: n_top_L ni_def)

lemma ni_galois:
  "ni(x) ≤ ni(y) ⟷ ni(x) ≤ y"
  by (metis n_galois n_n_L ni_def)

lemma ni_mult:
  "ni(x * ni(y)) = ni(x * y)"
  using mult_assoc n_mult ni_def by auto

lemma ni_n_order:
  "ni(x) ≤ ni(y) ⟷ n(x) ≤ n(y)"
  using n_galois ni_def ni_galois by auto

lemma ni_n_equal:
  "ni(x) = ni(y) ⟷ n(x) = n(y)"
  by (metis n_n_L ni_def)

lemma ni_mult_right_upper_bound:
  "ni(x * y) ≤ ni(z) ⟷ ni(x) ≤ ni(z) ∧ x * ni(y) ≤ x * bot ⊔ ni(z)"
  using mult_assoc n_mult_right_upper_bound ni_def ni_n_order by auto

lemma n_ni:
  "n(ni(x)) = n(x)"
  by (simp add: n_n_L ni_def)

lemma ni_n:
  "ni(n(x)) = bot"
  by (metis n_mult_right_bot ni_mult_bot ni_bot)

lemma ni_n_galois:
  "n(x) ≤ n(y) ⟷ ni(x) ≤ y"
  by (simp add: n_galois ni_def)

lemma n_mult_ni:
  "n(x * ni(y)) = n(x * y)"
  using ni_mult ni_n_equal by auto

lemma ni_mult_n:
  "ni(x * n(y)) = ni(x)"
  by (simp add: n_mult_n ni_def)

lemma ni_export:
  "ni(n(x) * y) = n(x) * ni(y)"
  by (simp add: n_mult_right_bot ni_split)

lemma ni_mult_top:
  "ni(x * n(y) * top) = ni(x * y)"
  by (simp add: n_mult_top ni_def)

lemma ni_n_bot:
  "ni(x) = bot ⟷ n(x) = bot"
  using n_bot ni_n_equal ni_bot by force

lemma ni_n_L:
  "ni(x) = L ⟷ n(x) = 1"
  using n_L ni_L ni_n_equal by force

(* independence of axioms, checked in n_semiring without the respective axiom:
lemma n_bot         : "n(bot) = bot" nitpick [expect=genuine,card=2] oops
lemma n_top         : "n(top) = 1" nitpick [expect=genuine,card=3] oops
lemma n_dist_sup    : "n(x ⊔ y) = n(x) ⊔ n(y)" nitpick [expect=genuine,card=5] oops
lemma n_export      : "n(n(x) * y) = n(x) * n(y)" nitpick [expect=genuine,card=6] oops
lemma n_sub_mult_bot: "n(x) = n(x * bot) * n(x)" nitpick [expect=genuine,card=2] oops
lemma n_L_split     : "x * n(y) * L = x * bot ⊔ n(x * y) * L" nitpick [expect=genuine,card=4] oops
lemma n_split       : "x ≤ x * bot ⊔ n(x * L) * top" nitpick [expect=genuine,card=3] oops
*)

end

typedef (overloaded) 'a nImage = "{ x::'a::n_semiring . (∃y::'a . x = n(y)) }"
  by auto

lemma simp_nImage[simp]:
  "∃y . Rep_nImage x = n(y)"
  using Rep_nImage by simp

setup_lifting type_definition_nImage

text ‹Theorem 15›

instantiation nImage :: (n_semiring) bounded_idempotent_semiring
begin

lift_definition sup_nImage :: "'a nImage ⇒ 'a nImage ⇒ 'a nImage" is sup
  by (metis n_dist_sup)

lift_definition times_nImage :: "'a nImage ⇒ 'a nImage ⇒ 'a nImage" is times
  by (metis n_export)

lift_definition bot_nImage :: "'a nImage" is bot
  by (metis n_bot)

lift_definition one_nImage :: "'a nImage" is 1
  using n_L by auto

lift_definition top_nImage :: "'a nImage" is 1
  using n_L by auto

lift_definition less_eq_nImage :: "'a nImage ⇒ 'a nImage ⇒ bool" is less_eq .

lift_definition less_nImage :: "'a nImage ⇒ 'a nImage ⇒ bool" is less .

instance
  apply intro_classes
  apply (simp add: less_eq_nImage.rep_eq less_le_not_le less_nImage.rep_eq)
  apply (simp add: less_eq_nImage.rep_eq)
  using less_eq_nImage.rep_eq apply force
  apply (simp add: less_eq_nImage.rep_eq Rep_nImage_inject)
  apply (simp add: sup_nImage.rep_eq less_eq_nImage.rep_eq)
  apply (simp add: less_eq_nImage.rep_eq sup_nImage.rep_eq)
  apply (simp add: sup_nImage.rep_eq less_eq_nImage.rep_eq)
  apply (simp add: bot_nImage.rep_eq less_eq_nImage.rep_eq)
  apply (simp add: sup_nImage.rep_eq times_nImage.rep_eq less_eq_nImage.rep_eq mult_left_dist_sup)
  apply (metis (mono_tags, lifting) sup_nImage.rep_eq times_nImage.rep_eq Rep_nImage_inverse mult_right_dist_sup)
  apply (smt (z3) times_nImage.rep_eq Rep_nImage_inverse bot_nImage.rep_eq mult_left_zero)
  using Rep_nImage_inject one_nImage.rep_eq times_nImage.rep_eq apply fastforce
  apply (simp add: one_nImage.rep_eq times_nImage.rep_eq less_eq_nImage.rep_eq)
  apply (smt (verit, del_insts) sup_nImage.rep_eq Rep_nImage Rep_nImage_inject mem_Collect_eq n_sub_one sup.absorb2 top_nImage.rep_eq)
  apply (simp add: less_eq_nImage.rep_eq mult.assoc times_nImage.rep_eq)
  using Rep_nImage_inject mult.assoc times_nImage.rep_eq apply fastforce
  using Rep_nImage_inject one_nImage.rep_eq times_nImage.rep_eq apply fastforce
  apply (metis (mono_tags, lifting) sup_nImage.rep_eq times_nImage.rep_eq Rep_nImage_inject mult_left_dist_sup)
  by (smt (z3) Rep_nImage_inject bot_nImage.rep_eq n_mult_right_bot simp_nImage times_nImage.rep_eq)

end

text ‹Theorem 15›

instantiation nImage :: (n_semiring) bounded_distrib_lattice
begin

lift_definition inf_nImage :: "'a nImage ⇒ 'a nImage ⇒ 'a nImage" is times
  by (metis n_export)

instance
  apply intro_classes
  apply (metis (mono_tags) inf_nImage.rep_eq less_eq_nImage.rep_eq n_mult_left_lower_bound simp_nImage)
  apply (metis (mono_tags) inf_nImage.rep_eq less_eq_nImage.rep_eq n_mult_right_lower_bound simp_nImage)
  apply (smt (z3) inf_nImage_def le_iff_sup less_eq_nImage.rep_eq mult_right_dist_sup n_mult_left_absorb_sup simp_nImage times_nImage.rep_eq times_nImage_def)
  apply simp
  by (smt (z3) Rep_nImage_inject inf_nImage.rep_eq n_sup_right_dist_mult simp_nImage sup.commute sup_nImage.rep_eq)

end

class n_itering = bounded_itering + n_semiring
begin

lemma mult_L_circ:
  "(x * L)⇧^∘ = 1 ⊔ x * L"
  by (metis L_left_zero circ_mult mult_assoc)

lemma mult_L_circ_mult:
  "(x * L)⇧^∘ * y = y ⊔ x * L"
  by (metis L_left_zero mult_L_circ mult_assoc mult_left_one mult_right_dist_sup)

lemma circ_L:
  "L⇧^∘ = L ⊔ 1"
  by (metis L_left_zero sup_commute circ_left_unfold)

lemma circ_n_L:
  "x⇧^∘ * n(x) * L = x⇧^∘ * bot"
  by (metis sup_bot_left circ_left_unfold circ_plus_same mult_left_zero n_L_split n_dist_sup n_mult_bot n_one ni_def ni_split)

lemma n_circ_left_unfold:
  "n(x⇧^∘) = n(x * x⇧^∘)"
  by (metis circ_n_L circ_plus_same n_mult n_mult_bot)

lemma ni_circ:
  "ni(x)⇧^∘ = 1 ⊔ ni(x)"
  by (simp add: mult_L_circ ni_def)

lemma circ_ni:
  "x⇧^∘ * ni(x) = x⇧^∘ * bot"
  using circ_n_L ni_def mult_assoc by auto

lemma ni_circ_left_unfold:
  "ni(x⇧^∘) = ni(x * x⇧^∘)"
  by (simp add: ni_def n_circ_left_unfold)

lemma n_circ_import:
  "n(y) * x ≤ x * n(y) ⟹ n(y) * x⇧^∘ = n(y) * (n(y) * x)⇧^∘"
  by (simp add: circ_import n_mult_idempotent n_sub_one)

end

class n_omega_itering = left_omega_conway_semiring + n_itering +
  assumes circ_circ: "x⇧^∘⇧^∘ = L ⊔ x⇧^⋆"
begin

lemma L_below_one_circ:
  "L ≤ 1⇧^∘"
  by (metis sup_left_divisibility circ_circ circ_one)

lemma circ_below_L_sup_star:
  "x⇧^∘ ≤ L ⊔ x⇧^⋆"
  by (metis circ_circ circ_increasing)

lemma L_sup_circ_sup_star:
  "L ⊔ x⇧^∘ = L ⊔ x⇧^⋆"
  by (metis circ_circ circ_star star_circ)

lemma circ_one_L:
  "1⇧^∘ = L ⊔ 1"
  using circ_circ circ_one star_one by auto

lemma one_circ_zero:
  "L = 1⇧^∘ * bot"
  by (metis L_left_zero circ_L circ_ni circ_one_L circ_plus_same ni_L)

lemma circ_not_simulate:
  "(∀x y z . x * z ≤ z * y ⟶ x⇧^∘ * z ≤ z * y⇧^∘) ⟶ 1 = bot"
  by (metis L_left_zero circ_one_L order.eq_iff mult_left_one mult_left_zero mult_right_sub_dist_sup_left n_L n_bot bot_least)

lemma star_circ_L:
  "x⇧^⋆⇧^∘ = L ⊔ x⇧^⋆"
  by (simp add: circ_circ star_circ)

lemma circ_circ_2:
  "x⇧^∘⇧^∘ = L ⊔ x⇧^∘"
  by (simp add: L_sup_circ_sup_star circ_circ)

lemma circ_sup_6:
  "L ⊔ (x ⊔ y)⇧^∘ = (x⇧^∘ * y⇧^∘)⇧^∘"
  by (metis circ_circ_2 sup_assoc sup_commute circ_sup_1 circ_circ_sup circ_decompose_4)

lemma circ_sup_7:
  "(x⇧^∘ * y⇧^∘)⇧^∘ = L ⊔ (x ⊔ y)⇧^⋆"
  using L_sup_circ_sup_star circ_sup_6 by auto

end

class n_omega_algebra_2 = bounded_left_zero_omega_algebra + n_semiring + Omega +
  assumes Omega_def: "x⇧^Ω = n(x⇧^ω) * L ⊔ x⇧^⋆"
begin

lemma mult_L_star:
  "(x * L)⇧^⋆ = 1 ⊔ x * L"
  by (simp add: L_left_zero transitive_star mult_assoc)

lemma mult_L_omega:
  "(x * L)⇧^ω = x * L"
  by (metis L_left_zero omega_slide)

lemma mult_L_sup_star:
  "(x * L ⊔ y)⇧^⋆ = y⇧^⋆ ⊔ y⇧^⋆ * x * L"
  by (metis L_left_zero star.mult_zero_sup_circ_2 sup_commute mult_assoc)

lemma mult_L_sup_omega:
  "(x * L ⊔ y)⇧^ω = y⇧^ω ⊔ y⇧^⋆ * x * L"
  by (metis L_left_zero mult_bot_add_omega sup_commute mult_assoc)

lemma mult_L_sup_circ:
  "(x * L ⊔ y)⇧^Ω = n(y⇧^ω) * L ⊔ y⇧^⋆ ⊔ y⇧^⋆ * x * L"
  by (smt sup_assoc sup_commute Omega_def le_iff_sup mult_L_sup_omega mult_L_sup_star mult_right_dist_sup n_L_decreasing n_dist_sup)

lemma circ_sup_n:
  "(x⇧^Ω * y)⇧^Ω * x⇧^Ω = n((x⇧^⋆ * y)⇧^ω) * L ⊔ ((x⇧^⋆ * y)⇧^⋆ * x⇧^⋆ ⊔ (x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L)"
  by (smt L_left_zero sup_assoc sup_commute Omega_def mult_L_sup_circ mult_assoc mult_left_dist_sup mult_right_dist_sup)

text ‹Theorem 20.6›

lemma n_omega_induct:
  "n(y) ≤ n(x * y ⊔ z) ⟹ n(y) ≤ n(x⇧^ω ⊔ x⇧^⋆ * z)"
  by (smt sup_commute mult_assoc n_dist_sup n_galois n_mult omega_induct)

lemma n_Omega_left_unfold:
  "1 ⊔ x * x⇧^Ω = x⇧^Ω"
proof -
  have "1 ⊔ x * x⇧^Ω = 1 ⊔ x * n(x⇧^ω) * L ⊔ x * x⇧^⋆"
    by (simp add: Omega_def semiring.distrib_left sup_assoc mult_assoc)
  also have "... = n(x * x⇧^ω) * L ⊔ (1 ⊔ x * x⇧^⋆)"
    by (metis sup_assoc sup_commute sup_bot_left mult_left_dist_sup n_L_split)
  also have "... = n(x⇧^ω) * L ⊔ x⇧^⋆"
    using omega_unfold star_left_unfold_equal by auto
  also have "... = x⇧^Ω"
    by (simp add: Omega_def)
  finally show ?thesis
    .
qed

lemma n_Omega_circ_sup:
  "(x ⊔ y)⇧^Ω = (x⇧^Ω * y)⇧^Ω * x⇧^Ω"
proof -
  have "(x⇧^Ω * y)⇧^Ω * x⇧^Ω = n((x⇧^⋆ * y)⇧^ω) * L ⊔ ((x⇧^⋆ * y)⇧^⋆ * x⇧^⋆ ⊔ (x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L)"
    by (simp add: circ_sup_n)
  also have "... = n((x⇧^⋆ * y)⇧^ω) * L ⊔ n((x⇧^⋆ * y)⇧^⋆ * x⇧^ω) * L ⊔ (x⇧^⋆ * y)⇧^⋆ * bot ⊔ (x⇧^⋆ * y)⇧^⋆ * x⇧^⋆"
    using n_L_split sup.left_commute sup_commute by auto
  also have "... = n((x⇧^⋆ * y)⇧^ω ⊔ (x⇧^⋆ * y)⇧^⋆ * x⇧^ω) * L ⊔ (x⇧^⋆ * y)⇧^⋆ * x⇧^⋆"
    by (smt sup_assoc sup_bot_left mult_left_dist_sup mult_right_dist_sup n_dist_sup)
  also have "... = (x ⊔ y)⇧^Ω"
    by (simp add: Omega_def omega_decompose star.circ_sup_9)
  finally show ?thesis
    ..
qed

lemma n_Omega_circ_simulate_right_sup:
  assumes "z * x ≤ y * y⇧^Ω * z ⊔ w"
    shows "z * x⇧^Ω ≤ y⇧^Ω * (z ⊔ w * x⇧^Ω)"
proof -
  have "z * x ≤ y * y⇧^Ω * z ⊔ w"
    by (simp add: assms)
  also have "... = y * n(y⇧^ω) * L ⊔ y * y⇧^⋆ * z ⊔ w"
    using L_left_zero Omega_def mult_right_dist_sup semiring.distrib_left mult_assoc by auto
  finally have 1: "z * x ≤ n(y⇧^ω) * L ⊔ y * y⇧^⋆ * z ⊔ w"
    by (metis sup_assoc sup_commute sup_bot_left mult_assoc mult_left_dist_sup n_L_split omega_unfold)
  hence "(n(y⇧^ω) * L ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * n(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆) * x ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ * (n(y⇧^ω) * L ⊔ y * y⇧^⋆ * z ⊔ w) ⊔ y⇧^⋆ * w * n(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (smt L_left_zero sup_assoc sup_ge1 sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_back_loop_fixpoint)
  also have "... = n(y⇧^ω) * L ⊔ y⇧^⋆ * n(y⇧^ω) * L ⊔ y⇧^⋆ * y * y⇧^⋆ * z ⊔ y⇧^⋆ * w ⊔ y⇧^⋆ * w * n(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    using semiring.distrib_left sup_assoc mult_assoc by auto
  also have "... = n(y⇧^ω) * L ⊔ y⇧^⋆ * n(y⇧^ω) * L ⊔ y⇧^⋆ * y * y⇧^⋆ * z ⊔ y⇧^⋆ * w * n(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (smt (verit, ccfv_SIG) le_supI1 order.refl semiring.add_mono star.circ_back_loop_prefixpoint sup.bounded_iff sup.coboundedI1 sup.mono sup_left_divisibility sup_right_divisibility sup_same_context)
  also have "... = n(y⇧^ω) * L ⊔ y⇧^⋆ * y * y⇧^⋆ * z ⊔ y⇧^⋆ * w * n(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (smt sup_assoc sup_commute sup_idem mult_assoc mult_left_dist_sup n_L_split star_mult_omega)
  also have "... ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * n(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (meson mult_left_isotone order_refl semiring.add_left_mono star.circ_mult_upper_bound star.right_plus_below_circ sup_left_isotone)
  finally have 2: "z * x⇧^⋆ ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * n(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (smt le_supI1 le_sup_iff sup_ge1 star.circ_loop_fixpoint star_right_induct)
  have "z * x * x⇧^ω ≤ n(y⇧^ω) * L ⊔ y * y⇧^⋆ * z * x⇧^ω ⊔ w * x⇧^ω"
    using 1 by (smt (verit, del_insts) L_left_zero mult_assoc mult_left_isotone mult_right_dist_sup)
  hence "n(z * x * x⇧^ω) ≤ n(y * y⇧^⋆ * z * x⇧^ω ⊔ n(y⇧^ω) * L ⊔ w * x⇧^ω)"
    by (simp add: n_isotone sup_commute)
  hence "n(z * x⇧^ω) ≤ n(y⇧^ω ⊔ y⇧^⋆ * w * x⇧^ω)"
    by (smt (verit, del_insts) sup_assoc sup_commute left_plus_omega le_iff_sup mult_assoc mult_left_dist_sup n_L_decreasing n_omega_induct omega_unfold star.left_plus_circ star_mult_omega)
  hence "n(z * x⇧^ω) * L ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ * w * n(x⇧^ω) * L"
    by (metis n_dist_sup n_galois n_mult n_n_L)
  hence "z * n(x⇧^ω) * L ≤ z * bot ⊔ n(y⇧^ω) * L ⊔ y⇧^⋆ * w * n(x⇧^ω) * L"
    using n_L_split semiring.add_left_mono sup_assoc by auto
  also have "... ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * n(x⇧^ω) * L"
    by (smt (z3) order.trans mult_1_left mult_right_sub_dist_sup_left semiring.add_right_mono star_left_unfold_equal sup_commute zero_right_mult_decreasing)
  finally have "z * n(x⇧^ω) * L ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * n(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    using le_supI1 by blast
  thus ?thesis
    using 2 by (smt L_left_zero Omega_def sup_assoc le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup)
qed

lemma n_Omega_circ_simulate_left_sup:
  assumes "x * z ≤ z * y⇧^Ω ⊔ w"
    shows "x⇧^Ω * z ≤ (z ⊔ x⇧^Ω * w) * y⇧^Ω"
proof -
  have "x * (z * n(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ n(x⇧^ω) * L ⊔ x⇧^⋆ * w * n(y⇧^ω) * L ⊔ x⇧^⋆ * w * y⇧^⋆) = x * z * n(y⇧^ω) * L ⊔ x * z * y⇧^⋆ ⊔ n(x⇧^ω) * L ⊔ x * x⇧^⋆ * w * n(y⇧^ω) * L ⊔ x * x⇧^⋆ * w * y⇧^⋆"
    by (smt sup_assoc sup_commute mult_assoc mult_left_dist_sup n_L_split omega_unfold)
  also have "... ≤ (z * n(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ w) * n(y⇧^ω) * L ⊔ (z * n(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ w) * y⇧^⋆ ⊔ n(x⇧^ω) * L ⊔ x⇧^⋆ * w * n(y⇧^ω) * L ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (smt assms Omega_def sup_assoc sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_loop_fixpoint)
  also have "... = z * n(y⇧^ω) * L ⊔ z * y⇧^⋆ * n(y⇧^ω) * L ⊔ w * n(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ w * y⇧^⋆ ⊔ n(x⇧^ω) * L ⊔ x⇧^⋆ * w * n(y⇧^ω) * L ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (smt L_left_zero sup_assoc sup_commute sup_idem mult_assoc mult_right_dist_sup star.circ_transitive_equal)
  also have "... = z * n(y⇧^ω) * L ⊔ w * n(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ w * y⇧^⋆ ⊔ n(x⇧^ω) * L ⊔ x⇧^⋆ * w * n(y⇧^ω) * L ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (smt sup_assoc sup_commute sup_idem le_iff_sup mult_assoc n_L_split star_mult_omega zero_right_mult_decreasing)
  finally have "x * (z * n(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ n(x⇧^ω) * L ⊔ x⇧^⋆ * w * n(y⇧^ω) * L ⊔ x⇧^⋆ * w * y⇧^⋆) ≤ z * n(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ n(x⇧^ω) * L ⊔ x⇧^⋆ * w * n(y⇧^ω) * L ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (smt sup_assoc sup_commute sup_idem mult_assoc star.circ_loop_fixpoint)
  thus "x⇧^Ω * z ≤ (z ⊔ x⇧^Ω * w) * y⇧^Ω"
    by (smt (verit, del_insts) L_left_zero Omega_def sup_assoc le_supI1 le_sup_iff sup_ge1 mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_back_loop_fixpoint star_left_induct)
qed

end

text ‹Theorem 2.6 and Theorem 19›

sublocale n_omega_algebra_2 < nL_omega: itering where circ = Omega
  apply unfold_locales
  apply (simp add: n_Omega_circ_sup)
  apply (smt L_left_zero sup_assoc sup_commute sup_bot_left Omega_def mult_assoc mult_left_dist_sup mult_right_dist_sup n_L_split omega_slide star.circ_mult)
  apply (simp add: n_Omega_circ_simulate_right_sup)
  using n_Omega_circ_simulate_left_sup by auto

sublocale n_omega_algebra_2 < nL_omega: n_omega_itering where circ = Omega
  apply unfold_locales
  by (smt Omega_def sup_assoc sup_commute le_iff_sup mult_L_sup_star mult_left_one n_L_split n_top ni_below_L ni_def star_involutive star_mult_omega star_omega_top zero_right_mult_decreasing)

sublocale n_omega_algebra_2 < nL_omega: left_zero_kleene_conway_semiring where circ = Omega ..

sublocale n_omega_algebra_2 < nL_star: left_omega_conway_semiring where circ = star ..

context n_omega_algebra_2
begin

lemma circ_sup_8:
  "n((x⇧^⋆ * y)⇧^⋆ * x⇧^ω) * L ≤ (x⇧^⋆ * y)⇧^Ω * x⇧^Ω"
  by (metis sup_ge1 nL_omega.circ_sup_4 Omega_def mult_left_isotone n_isotone omega_sum_unfold_3 order_trans)

lemma n_split_omega_omega:
  "x⇧^ω ≤ x⇧^ω * bot ⊔ n(x⇧^ω) * top"
  by (metis n_split n_top_L omega_vector)

text ‹Theorem 20.1›

lemma n_below_n_star:
  "n(x) ≤ n(x⇧^⋆)"
  by (simp add: n_isotone star.circ_increasing)

text ‹Theorem 20.2›

lemma n_star_below_n_omega:
  "n(x⇧^⋆) ≤ n(x⇧^ω)"
  by (metis n_mult_left_upper_bound star_mult_omega)

lemma n_below_n_omega:
  "n(x) ≤ n(x⇧^ω)"
  using order.trans n_below_n_star n_star_below_n_omega by blast

text ‹Theorem 20.4›

lemma star_n_L:
  "x⇧^⋆ * n(x) * L = x⇧^⋆ * bot"
  by (metis sup_bot_left mult_left_zero n_L_split n_dist_sup n_mult_bot n_one ni_def ni_split star_left_unfold_equal star_plus)

lemma star_L_split:
  assumes "y ≤ z"
      and "x * z * L ≤ x * bot ⊔ z * L"
    shows "x⇧^⋆ * y * L ≤ x⇧^⋆ * bot ⊔ z * L"
proof -
  have "x * (x⇧^⋆ * bot ⊔ z * L) ≤ x⇧^⋆ * bot ⊔ x * z * L"
    by (metis sup_bot_right order.eq_iff mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
  also have "... ≤ x⇧^⋆ * bot ⊔ x * bot ⊔ z * L"
    using assms(2) semiring.add_left_mono sup_assoc by auto
  also have "... = x⇧^⋆ * bot ⊔ z * L"
    using mult_left_isotone star.circ_increasing sup.absorb_iff2 sup_commute by auto
  finally have "y * L ⊔ x * (x⇧^⋆ * bot ⊔ z * L) ≤ x⇧^⋆ * bot ⊔ z * L"
    by (metis assms(1) le_sup_iff sup_ge2 mult_left_isotone order_trans)
  thus ?thesis
    by (simp add: star_left_induct mult_assoc)
qed

lemma star_L_split_same:
  "x * y * L ≤ x * bot ⊔ y * L ⟹ x⇧^⋆ * y * L = x⇧^⋆ * bot ⊔ y * L"
  apply (rule order.antisym)
  apply (simp add: star_L_split)
  by (metis bot_least le_supI mult_isotone nL_star.star_below_circ star.circ_loop_fixpoint sup.cobounded2 mult_assoc)

lemma star_n_L_split_equal:
  "n(x * y) ≤ n(y) ⟹ x⇧^⋆ * n(y) * L = x⇧^⋆ * bot ⊔ n(y) * L"
  by (simp add: n_mult_right_upper_bound star_L_split_same)

lemma n_star_mult:
  "n(x * y) ≤ n(y) ⟹ n(x⇧^⋆ * y) = n(x⇧^⋆) ⊔ n(y)"
  by (metis n_dist_sup n_mult n_mult_bot n_n_L star_n_L_split_equal)

text ‹Theorem 20.3›

lemma n_omega_mult:
  "n(x⇧^ω * y) = n(x⇧^ω)"
  by (simp add: n_isotone n_mult_left_upper_bound omega_sub_vector order.eq_iff)

lemma n_star_left_unfold:
  "n(x⇧^⋆) = n(x * x⇧^⋆)"
  by (metis n_mult n_mult_bot star.circ_plus_same star_n_L)

lemma ni_star_below_ni_omega:
  "ni(x⇧^⋆) ≤ ni(x⇧^ω)"
  by (simp add: ni_n_order n_star_below_n_omega)

lemma ni_below_ni_omega:
  "ni(x) ≤ ni(x⇧^ω)"
  by (simp add: ni_n_order n_below_n_omega)

lemma ni_star:
  "ni(x)⇧^⋆ = 1 ⊔ ni(x)"
  by (simp add: mult_L_star ni_def)

lemma ni_omega:
  "ni(x)⇧^ω = ni(x)"
  using mult_L_omega ni_def by auto

lemma ni_omega_induct:
  "ni(y) ≤ ni(x * y ⊔ z) ⟹ ni(y) ≤ ni(x⇧^ω ⊔ x⇧^⋆ * z)"
  using n_omega_induct ni_n_order by blast

lemma star_ni:
  "x⇧^⋆ * ni(x) = x⇧^⋆ * bot"
  using ni_def mult_assoc star_n_L by auto

lemma star_ni_split_equal:
  "ni(x * y) ≤ ni(y) ⟹ x⇧^⋆ * ni(y) = x⇧^⋆ * bot ⊔ ni(y)"
  using ni_def ni_mult_right_upper_bound mult_assoc star_L_split_same by auto

lemma ni_star_mult:
  "ni(x * y) ≤ ni(y) ⟹ ni(x⇧^⋆ * y) = ni(x⇧^⋆) ⊔ ni(y)"
  using mult_right_dist_sup ni_def ni_n_order n_star_mult by auto

lemma ni_omega_mult:
  "ni(x⇧^ω * y) = ni(x⇧^ω)"
  by (simp add: ni_def n_omega_mult)

lemma ni_star_left_unfold:
  "ni(x⇧^⋆) = ni(x * x⇧^⋆)"
  by (simp add: ni_def n_star_left_unfold)

lemma n_star_import:
  assumes "n(y) * x ≤ x * n(y)"
    shows "n(y) * x⇧^⋆ = n(y) * (n(y) * x)⇧^⋆"
proof (rule order.antisym)
  have "n(y) * (n(y) * x)⇧^⋆ * x ≤ n(y) * (n(y) * x)⇧^⋆"
    by (smt assms mult_assoc mult_right_dist_sup mult_right_sub_dist_sup_left n_mult_idempotent n_preserves_equation star.circ_back_loop_fixpoint)
  thus "n(y) * x⇧^⋆ ≤ n(y) * (n(y) * x)⇧^⋆"
    using assms eq_refl n_mult_idempotent n_sub_one star.circ_import by auto
next
  show "n(y) * (n(y) * x)⇧^⋆ ≤ n(y) * x⇧^⋆"
    by (simp add: assms n_mult_idempotent n_sub_one star.circ_import)
qed

lemma n_omega_export:
  "n(y) * x ≤ x * n(y) ⟹ n(y) * x⇧^ω = (n(y) * x)⇧^ω"
  apply (rule order.antisym)
  apply (simp add: n_preserves_equation omega_simulation)
  by (metis mult_right_isotone mult_1_right n_sub_one omega_isotone omega_slide)

lemma n_omega_import:
  "n(y) * x ≤ x * n(y) ⟹ n(y) * x⇧^ω = n(y) * (n(y) * x)⇧^ω"
  by (simp add: n_mult_idempotent omega_import)

text ‹Theorem 20.5›

lemma star_n_omega_top:
  "x⇧^⋆ * n(x⇧^ω) * top = x⇧^⋆ * bot ⊔ n(x⇧^ω) * top"
  by (smt (verit, del_insts) le_supI le_sup_iff sup_right_divisibility order.antisym mult_assoc nL_star.circ_mult_omega nL_star.star_zero_below_circ_mult n_top_split star.circ_loop_fixpoint)

(*
lemma n_star_induct_sup: "n(z ⊔ x * y) ≤ n(y) ⟹ n(x⇧^⋆ * z) ≤ n(y)" oops
*)

end

end

Theory N_Semirings_Boolean

(* Title:      Boolean N-Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Boolean N-Semirings›

theory N_Semirings_Boolean

imports N_Semirings

begin

class an =
  fixes an :: "'a ⇒ 'a"

class an_semiring = bounded_idempotent_left_zero_semiring + L + n + an + uminus +
  assumes an_complement: "an(x) ⊔ n(x) = 1"
  assumes an_dist_sup  : "an(x ⊔ y) = an(x) * an(y)"
  assumes an_export    : "an(an(x) * y) = n(x) ⊔ an(y)"
  assumes an_mult_zero : "an(x) = an(x * bot)"
  assumes an_L_split   : "x * n(y) * L = x * bot ⊔ n(x * y) * L"
  assumes an_split     : "an(x * L) * x ≤ x * bot"
  assumes an_uminus    : "-x = an(x * L)"
begin

text ‹Theorem 21›

lemma n_an_def:
  "n(x) = an(an(x) * L)"
  by (metis an_dist_sup an_export an_split bot_least mult_right_isotone semiring.add_nonneg_eq_0_iff sup.orderE top_greatest vector_bot_closed)

text ‹Theorem 21›

lemma an_complement_bot:
  "an(x) * n(x) = bot"
  by (metis an_dist_sup an_split bot_least le_iff_sup mult_left_zero sup_commute n_an_def)

text ‹Theorem 21›

lemma an_n_def:
  "an(x) = n(an(x) * L)"
  by (smt (verit, ccfv_threshold) an_complement_bot an_complement mult.right_neutral mult_left_dist_sup mult_right_dist_sup sup_commute n_an_def)

lemma an_case_split_left:
  "an(z) * x ≤ y ∧ n(z) * x ≤ y ⟷ x ≤ y"
  by (metis le_sup_iff an_complement mult_left_one mult_right_dist_sup)

lemma an_case_split_right:
  "x * an(z) ≤ y ∧ x * n(z) ≤ y ⟷ x ≤ y"
  by (metis le_sup_iff an_complement mult_1_right mult_left_dist_sup)

lemma split_sub:
  "x * y ≤ z ⊔ x * top"
  by (simp add: le_supI2 mult_right_isotone)

text ‹Theorem 21›

subclass n_semiring
  apply unfold_locales
  apply (metis an_dist_sup an_split mult_left_zero sup.absorb2 sup_bot_left sup_commute n_an_def)
  apply (metis sup_left_top an_complement an_dist_sup an_export mult_assoc n_an_def)
  apply (metis an_dist_sup an_export mult_assoc n_an_def)
  apply (metis an_dist_sup an_export an_n_def mult_right_dist_sup n_an_def)
  apply (metis sup_idem an_dist_sup an_mult_zero n_an_def)
  apply (simp add: an_L_split)
  by (meson an_case_split_left an_split le_supI1 split_sub)

lemma n_complement_bot:
  "n(x) * an(x) = bot"
  by (metis an_complement_bot an_n_def n_an_def)

lemma an_bot:
  "an(bot) = 1"
  by (metis sup_bot_right an_complement n_bot)

lemma an_one:
  "an(1) = 1"
  by (metis sup_bot_right an_complement n_one)

lemma an_L:
  "an(L) = bot"
  using an_one n_one n_an_def by auto

lemma an_top:
  "an(top) = bot"
  by (metis mult_left_one n_complement_bot n_top)

lemma an_export_n:
  "an(n(x) * y) = an(x) ⊔ an(y)"
  by (metis an_export an_n_def n_an_def)

lemma n_export_an:
  "n(an(x) * y) = an(x) * n(y)"
  by (metis an_n_def n_export)

lemma n_an_mult_commutative:
  "n(x) * an(y) = an(y) * n(x)"
  by (metis sup_commute an_dist_sup n_an_def)

lemma an_mult_commutative:
  "an(x) * an(y) = an(y) * an(x)"
  by (metis sup_commute an_dist_sup)

lemma an_mult_idempotent:
  "an(x) * an(x) = an(x)"
  by (metis sup_idem an_dist_sup)

lemma an_sub_one:
  "an(x) ≤ 1"
  using an_complement sup.cobounded1 by fastforce

text ‹Theorem 21›

lemma an_antitone:
  "x ≤ y ⟹ an(y) ≤ an(x)"
  by (metis an_n_def an_dist_sup n_order sup.absorb1)

lemma an_mult_left_upper_bound:
  "an(x * y) ≤ an(x)"
  by (metis an_antitone an_mult_zero mult_right_isotone bot_least)

lemma an_mult_right_zero:
  "an(x) * bot = bot"
  by (metis an_n_def n_mult_right_bot)

lemma n_mult_an:
  "n(x * an(y)) = n(x)"
  by (metis an_n_def n_mult_n)

lemma an_mult_n:
  "an(x * n(y)) = an(x)"
  by (metis an_n_def n_an_def n_mult_n)

lemma an_mult_an:
  "an(x * an(y)) = an(x)"
  by (metis an_mult_n an_n_def)

lemma an_mult_left_absorb_sup:
  "an(x) * (an(x) ⊔ an(y)) = an(x)"
  by (metis an_n_def n_mult_left_absorb_sup)

lemma an_mult_right_absorb_sup:
  "(an(x) ⊔ an(y)) * an(y) = an(y)"
  by (metis an_n_def n_mult_right_absorb_sup)

lemma an_sup_left_absorb_mult:
  "an(x) ⊔ an(x) * an(y) = an(x)"
  using an_case_split_right sup_absorb1 by blast

lemma an_sup_right_absorb_mult:
  "an(x) * an(y) ⊔ an(y) = an(y)"
  using an_case_split_left sup_absorb2 by blast

lemma an_sup_left_dist_mult:
  "an(x) ⊔ an(y) * an(z) = (an(x) ⊔ an(y)) * (an(x) ⊔ an(z))"
  by (metis an_n_def n_sup_left_dist_mult)

lemma an_sup_right_dist_mult:
  "an(x) * an(y) ⊔ an(z) = (an(x) ⊔ an(z)) * (an(y) ⊔ an(z))"
  by (simp add: an_sup_left_dist_mult sup_commute)

lemma an_n_order:
  "an(x) ≤ an(y) ⟷ n(y) ≤ n(x)"
  by (smt (verit) an_n_def an_dist_sup le_iff_sup n_dist_sup n_mult_right_absorb_sup sup.orderE n_an_def)

lemma an_order:
  "an(x) ≤ an(y) ⟷ an(x) * an(y) = an(x)"
  by (metis an_n_def n_order)

lemma an_mult_left_lower_bound:
  "an(x) * an(y) ≤ an(x)"
  using an_case_split_right by blast

lemma an_mult_right_lower_bound:
  "an(x) * an(y) ≤ an(y)"
  by (simp add: an_sup_right_absorb_mult le_iff_sup)

lemma an_n_mult_left_lower_bound:
  "an(x) * n(y) ≤ an(x)"
  using an_case_split_right by blast

lemma an_n_mult_right_lower_bound:
  "an(x) * n(y) ≤ n(y)"
  using an_case_split_left by auto

lemma n_an_mult_left_lower_bound:
  "n(x) * an(y) ≤ n(x)"
  using an_case_split_right by auto

lemma n_an_mult_right_lower_bound:
  "n(x) * an(y) ≤ an(y)"
  using an_case_split_left by blast

lemma an_mult_least_upper_bound:
  "an(x) ≤ an(y) ∧ an(x) ≤ an(z) ⟷ an(x) ≤ an(y) * an(z)"
  by (metis an_mult_idempotent an_mult_left_lower_bound an_mult_right_lower_bound order.trans mult_isotone)

lemma an_mult_left_divisibility:
  "an(x) ≤ an(y) ⟷ (∃z . an(x) = an(y) * an(z))"
  by (metis an_mult_commutative an_mult_left_lower_bound an_order)

lemma an_mult_right_divisibility:
  "an(x) ≤ an(y) ⟷ (∃z . an(x) = an(z) * an(y))"
  by (simp add: an_mult_commutative an_mult_left_divisibility)

lemma an_split_top:
  "an(x * L) * x * top ≤ x * bot"
  by (metis an_split mult_assoc mult_left_isotone mult_left_zero)

lemma an_n_L:
  "an(n(x) * L) = an(x)"
  using an_n_def n_an_def by auto

lemma an_galois:
  "an(y) ≤ an(x) ⟷ n(x) * L ≤ y"
  by (simp add: an_n_order n_galois)

lemma an_mult:
  "an(x * n(y) * L) = an(x * y)"
  by (metis an_n_L n_mult)

lemma n_mult_top:
  "an(x * n(y) * top) = an(x * y)"
  by (metis an_n_L n_mult_top)

lemma an_n_equal:
  "an(x) = an(y) ⟷ n(x) = n(y)"
  by (metis an_n_L n_an_def)

lemma an_top_L:
  "an(x * top) = an(x * L)"
  by (simp add: an_n_equal n_top_L)

lemma an_case_split_left_equal:
  "an(z) * x = an(z) * y ⟹ n(z) * x = n(z) * y ⟹ x = y"
  using an_complement case_split_left_equal by blast

lemma an_case_split_right_equal:
  "x * an(z) = y * an(z) ⟹ x * n(z) = y * n(z) ⟹ x = y"
  using an_complement case_split_right_equal by blast

lemma an_equal_complement:
  "n(x) ⊔ an(y) = 1 ∧ n(x) * an(y) = bot ⟷ an(x) = an(y)"
  by (metis sup_commute an_complement an_dist_sup mult_left_one mult_right_dist_sup n_complement_bot)

lemma n_equal_complement:
  "n(x) ⊔ an(y) = 1 ∧ n(x) * an(y) = bot ⟷ n(x) = n(y)"
  by (simp add: an_equal_complement an_n_equal)

lemma an_shunting:
  "an(z) * x ≤ y ⟷ x ≤ y ⊔ n(z) * top"
  apply (rule iffI)
  apply (meson an_case_split_left le_supI1 split_sub)
  by (metis sup_bot_right an_case_split_left an_complement_bot mult_assoc mult_left_dist_sup mult_left_zero mult_right_isotone order_refl order_trans)

lemma an_shunting_an:
  "an(z) * an(x) ≤ an(y) ⟷ an(x) ≤ n(z) ⊔ an(y)"
  apply (rule iffI)
  apply (smt sup_ge1 sup_ge2 an_case_split_left n_an_mult_left_lower_bound order_trans)
  by (metis sup_bot_left sup_ge2 an_case_split_left an_complement_bot mult_left_dist_sup mult_right_isotone order_trans)

lemma an_L_zero:
  "an(x * L) * x = an(x * L) * x * bot"
  by (metis an_complement_bot n_split_equal sup_monoid.add_0_right vector_bot_closed mult_assoc n_export_an)

lemma n_plus_complement_intro_n:
  "n(x) ⊔ an(x) * n(y) = n(x) ⊔ n(y)"
  by (metis sup_commute an_complement an_n_def mult_1_right n_sup_right_dist_mult n_an_mult_commutative)

lemma n_plus_complement_intro_an:
  "n(x) ⊔ an(x) * an(y) = n(x) ⊔ an(y)"
  by (metis an_n_def n_plus_complement_intro_n)

lemma an_plus_complement_intro_n:
  "an(x) ⊔ n(x) * n(y) = an(x) ⊔ n(y)"
  by (metis an_n_def n_an_def n_plus_complement_intro_n)

lemma an_plus_complement_intro_an:
  "an(x) ⊔ n(x) * an(y) = an(x) ⊔ an(y)"
  by (metis an_n_def an_plus_complement_intro_n)

lemma n_mult_complement_intro_n:
  "n(x) * (an(x) ⊔ n(y)) = n(x) * n(y)"
  by (simp add: mult_left_dist_sup n_complement_bot)

lemma n_mult_complement_intro_an:
  "n(x) * (an(x) ⊔ an(y)) = n(x) * an(y)"
  by (simp add: semiring.distrib_left n_complement_bot)

lemma an_mult_complement_intro_n:
  "an(x) * (n(x) ⊔ n(y)) = an(x) * n(y)"
  by (simp add: an_complement_bot mult_left_dist_sup)

lemma an_mult_complement_intro_an:
  "an(x) * (n(x) ⊔ an(y)) = an(x) * an(y)"
  by (simp add: an_complement_bot semiring.distrib_left)

lemma an_preserves_equation:
  "an(y) * x ≤ x * an(y) ⟷ an(y) * x = an(y) * x * an(y)"
  by (metis an_n_def n_preserves_equation)

lemma wnf_lemma_1:
  "(n(p * L) * n(q * L) ⊔ an(p * L) * an(r * L)) * n(p * L) = n(p * L) * n(q * L)"
  by (smt sup_commute an_n_def n_sup_left_absorb_mult n_sup_right_dist_mult n_export n_mult_commutative n_mult_complement_intro_n)

lemma wnf_lemma_2:
  "(n(p * L) * n(q * L) ⊔ an(r * L) * an(q * L)) * n(q * L) = n(p * L) * n(q * L)"
  by (metis an_mult_commutative n_mult_commutative wnf_lemma_1)

lemma wnf_lemma_3:
  "(n(p * L) * n(r * L) ⊔ an(p * L) * an(q * L)) * an(p * L) = an(p * L) * an(q * L)"
  by (metis an_n_def sup_commute wnf_lemma_1 n_an_def)

lemma wnf_lemma_4:
  "(n(r * L) * n(q * L) ⊔ an(p * L) * an(q * L)) * an(q * L) = an(p * L) * an(q * L)"
  by (metis an_mult_commutative n_mult_commutative wnf_lemma_3)

lemma wnf_lemma_5:
  "n(p ⊔ q) * (n(q) * x ⊔ an(q) * y) = n(q) * x ⊔ an(q) * n(p) * y"
  by (smt sup_bot_right mult_assoc mult_left_dist_sup n_an_mult_commutative n_complement_bot n_dist_sup n_mult_right_absorb_sup)

definition ani :: "'a ⇒ 'a"
  where "ani x ≡ an(x) * L"

lemma ani_bot:
  "ani(bot) = L"
  using an_bot ani_def by auto

lemma ani_one:
  "ani(1) = L"
  using an_one ani_def by auto

lemma ani_L:
  "ani(L) = bot"
  by (simp add: an_L ani_def)

lemma ani_top:
  "ani(top) = bot"
  by (simp add: an_top ani_def)

lemma ani_complement:
  "ani(x) ⊔ ni(x) = L"
  by (metis an_complement ani_def mult_right_dist_sup n_top ni_def ni_top)

lemma ani_mult_zero:
  "ani(x) = ani(x * bot)"
  using ani_def an_mult_zero by auto

lemma ani_antitone:
  "y ≤ x ⟹ ani(x) ≤ ani(y)"
  by (simp add: an_antitone ani_def mult_left_isotone)

lemma ani_mult_left_upper_bound:
  "ani(x * y) ≤ ani(x)"
  by (simp add: an_mult_left_upper_bound ani_def mult_left_isotone)

lemma ani_involutive:
  "ani(ani(x)) = ni(x)"
  by (simp add: ani_def ni_def n_an_def)

lemma ani_below_L:
  "ani(x) ≤ L"
  using an_case_split_left ani_def by auto

lemma ani_left_zero:
  "ani(x) * y = ani(x)"
  by (simp add: ani_def L_left_zero mult_assoc)

lemma ani_top_L:
  "ani(x * top) = ani(x * L)"
  by (simp add: an_top_L ani_def)

lemma ani_ni_order:
  "ani(x) ≤ ani(y) ⟷ ni(y) ≤ ni(x)"
  by (metis an_n_L ani_antitone ani_def ani_involutive ni_def)

lemma ani_ni_equal:
  "ani(x) = ani(y) ⟷ ni(x) = ni(y)"
  by (metis ani_ni_order order.antisym order_refl)

lemma ni_ani:
  "ni(ani(x)) = ani(x)"
  using an_n_def ani_def ni_def by auto

lemma ani_ni:
  "ani(ni(x)) = ani(x)"
  by (simp add: an_n_L ani_def ni_def)

lemma ani_mult:
  "ani(x * ni(y)) = ani(x * y)"
  using ani_ni_equal ni_mult by blast

lemma ani_an_order:
  "ani(x) ≤ ani(y) ⟷ an(x) ≤ an(y)"
  using an_galois ani_ni_order ni_def ni_galois by auto

lemma ani_an_equal:
  "ani(x) = ani(y) ⟷ an(x) = an(y)"
  by (metis an_n_def ani_def)

lemma n_mult_ani:
  "n(x) * ani(x) = bot"
  by (metis an_L ani_L ani_def mult_assoc n_complement_bot)

lemma an_mult_ni:
  "an(x) * ni(x) = bot"
  by (metis an_n_def ani_def n_an_def n_mult_ani ni_def)

lemma n_mult_ni:
  "n(x) * ni(x) = ni(x)"
  by (metis n_export n_order ni_def ni_export order_refl)

lemma an_mult_ani:
  "an(x) * ani(x) = ani(x)"
  by (metis an_n_def ani_def n_mult_ni ni_def)

lemma ani_ni_meet:
  "x ≤ ani(y) ⟹ x ≤ ni(y) ⟹ x = bot"
  by (metis an_case_split_left an_mult_ni bot_unique mult_right_isotone n_mult_ani)

lemma ani_galois:
  "ani(x) ≤ y ⟷ ni(x ⊔ y) = L"
  apply (rule iffI)
  apply (smt (z3) an_L an_mult_commutative an_mult_right_zero ani_def an_dist_sup ni_L ni_n_equal sup.absorb1 mult_assoc n_an_def n_complement_bot)
  by (metis an_L an_galois an_mult_ni an_n_def an_shunting_an ani_def an_dist_sup an_export idempotent_bot_closed n_bot transitive_bot_closed)

lemma an_ani:
  "an(ani(x)) = n(x)"
  by (simp add: ani_def n_an_def)

lemma n_ani:
  "n(ani(x)) = an(x)"
  using an_n_def ani_def by auto

lemma an_ni:
  "an(ni(x)) = an(x)"
  by (simp add: an_n_L ni_def)

lemma ani_an:
  "ani(an(x)) = L"
  by (metis an_mult_right_zero an_mult_zero an_bot ani_def mult_left_one)

lemma ani_n:
  "ani(n(x)) = L"
  by (simp add: ani_an n_an_def)

lemma ni_an:
  "ni(an(x)) = bot"
  using an_L ani_an ani_def ni_n_bot n_an_def by force

lemma ani_mult_n:
  "ani(x * n(y)) = ani(x)"
  by (simp add: an_mult_n ani_def)

lemma ani_mult_an:
  "ani(x * an(y)) = ani(x)"
  by (simp add: an_mult_an ani_def)

lemma ani_export_n:
  "ani(n(x) * y) = ani(x) ⊔ ani(y)"
  by (simp add: an_export_n ani_def mult_right_dist_sup)

lemma ani_export_an:
  "ani(an(x) * y) = ni(x) ⊔ ani(y)"
  by (simp add: ani_def an_export ni_def semiring.distrib_right)

lemma ni_export_an:
  "ni(an(x) * y) = an(x) * ni(y)"
  by (simp add: an_mult_right_zero ni_split)

lemma ani_mult_top:
  "ani(x * n(y) * top) = ani(x * y)"
  using ani_def n_mult_top by auto

lemma ani_an_bot:
  "ani(x) = bot ⟷ an(x) = bot"
  using an_L ani_L ani_an_equal by force

lemma ani_an_L:
  "ani(x) = L ⟷ an(x) = 1"
  using an_bot ani_an_equal ani_bot by force

text ‹Theorem 21›

subclass tests
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (simp add: an_mult_commutative an_uminus)
  apply (smt an_sup_left_dist_mult an_export_n an_n_L an_uminus n_an_def n_complement_bot n_export)
  apply (metis an_dist_sup an_n_def an_uminus n_an_def)
  using an_complement_bot an_uminus n_an_def apply fastforce
  apply (simp add: an_bot an_uminus)
  using an_export_n an_mult an_uminus n_an_def apply fastforce
  using an_order an_uminus apply force
  by (simp add: less_le_not_le)

end

class an_itering = n_itering + an_semiring + while +
  assumes while_circ_def: "p ⋆ y = (p * y)⇧^∘ * -p"
begin

subclass test_itering
  apply unfold_locales
  by (rule while_circ_def)

lemma an_circ_left_unfold:
  "an(x⇧^∘) = an(x * x⇧^∘)"
  by (metis an_dist_sup an_one circ_left_unfold mult_left_one)

lemma an_circ_x_n_circ:
  "an(x⇧^∘) * x * n(x⇧^∘) ≤ x * bot"
  by (metis an_circ_left_unfold an_mult an_split mult_assoc n_mult_right_bot)

lemma an_circ_invariant:
  "an(x⇧^∘) * x ≤ x * an(x⇧^∘)"
proof -
  have 1: "an(x⇧^∘) * x * an(x⇧^∘) ≤ x * an(x⇧^∘)"
    by (metis an_case_split_left mult_assoc order_refl)
  have "an(x⇧^∘) * x * n(x⇧^∘) ≤ x * an(x⇧^∘)"
    by (metis an_circ_x_n_circ order_trans mult_right_isotone bot_least)
  thus ?thesis
    using 1 an_case_split_right by blast
qed

lemma ani_circ:
  "ani(x)⇧^∘ = 1 ⊔ ani(x)"
  by (simp add: ani_def mult_L_circ)

lemma ani_circ_left_unfold:
  "ani(x⇧^∘) = ani(x * x⇧^∘)"
  by (simp add: an_circ_left_unfold ani_def)

lemma an_circ_import:
  "an(y) * x ≤ x * an(y) ⟹ an(y) * x⇧^∘ = an(y) * (an(y) * x)⇧^∘"
  by (metis an_n_def n_circ_import)

lemma preserves_L:
  "preserves L (-p)"
  using L_left_zero preserves_equation_test mult_assoc by force

end

class an_omega_algebra = n_omega_algebra_2 + an_semiring + while +
  assumes while_Omega_def: "p ⋆ y = (p * y)⇧^Ω * -p"
begin

lemma an_split_omega_omega:
  "an(x⇧^ω) * x⇧^ω ≤ x⇧^ω * bot"
  by (meson an_antitone an_split mult_left_isotone omega_sub_vector order_trans)

lemma an_omega_below_an_star:
  "an(x⇧^ω) ≤ an(x⇧^⋆)"
  by (simp add: an_n_order n_star_below_n_omega)

lemma an_omega_below_an:
  "an(x⇧^ω) ≤ an(x)"
  by (simp add: an_n_order n_below_n_omega)

lemma an_omega_induct:
  "an(x * y ⊔ z) ≤ an(y) ⟹ an(x⇧^ω ⊔ x⇧^⋆ * z) ≤ an(y)"
  by (simp add: an_n_order n_omega_induct)

lemma an_star_mult:
  "an(y) ≤ an(x * y) ⟹ an(x⇧^⋆ * y) = an(x⇧^⋆) * an(y)"
  by (metis an_dist_sup an_n_L an_n_order n_dist_sup n_star_mult)

lemma an_omega_mult:
  "an(x⇧^ω * y) = an(x⇧^ω)"
  by (simp add: an_n_equal n_omega_mult)

lemma an_star_left_unfold:
  "an(x⇧^⋆) = an(x * x⇧^⋆)"
  by (simp add: an_n_equal n_star_left_unfold)

lemma an_star_x_n_star:
  "an(x⇧^⋆) * x * n(x⇧^⋆) ≤ x * bot"
  by (metis an_n_L an_split n_mult n_mult_right_bot n_star_left_unfold mult_assoc)

lemma an_star_invariant:
  "an(x⇧^⋆) * x ≤ x * an(x⇧^⋆)"
proof -
  have 1: "an(x⇧^⋆) * x * an(x⇧^⋆) ≤ x * an(x⇧^⋆)"
    using an_case_split_left mult_assoc by auto
  have "an(x⇧^⋆) * x * n(x⇧^⋆) ≤ x * an(x⇧^⋆)"
    by (metis an_star_x_n_star order_trans mult_right_isotone bot_least)
  thus ?thesis
    using 1 an_case_split_right by auto
qed

lemma n_an_star_unfold_invariant:
  "n(an(x⇧^⋆) * x⇧^ω) ≤ an(x) * n(x * an(x⇧^⋆) * x⇧^ω)"
proof -
  have "n(an(x⇧^⋆) * x⇧^ω) ≤ an(x)"
    using an_star_left_unfold an_case_split_right an_mult_left_upper_bound n_export_an by fastforce
  thus ?thesis
    by (smt an_star_invariant le_iff_sup mult_assoc mult_right_dist_sup n_isotone n_order omega_unfold)
qed

lemma ani_omega_below_ani_star:
  "ani(x⇧^ω) ≤ ani(x⇧^⋆)"
  by (simp add: an_omega_below_an_star ani_an_order)

lemma ani_omega_below_ani:
  "ani(x⇧^ω) ≤ ani(x)"
  by (simp add: an_omega_below_an ani_an_order)

lemma ani_star:
  "ani(x)⇧^⋆ = 1 ⊔ ani(x)"
  by (simp add: ani_def mult_L_star)

lemma ani_omega:
  "ani(x)⇧^ω = ani(x) * L"
  by (simp add: L_left_zero ani_def mult_L_omega mult_assoc)

lemma ani_omega_induct:
  "ani(x * y ⊔ z) ≤ ani(y) ⟹ ani(x⇧^ω ⊔ x⇧^⋆ * z) ≤ ani(y)"
  by (simp add: an_omega_induct ani_an_order)

lemma ani_omega_mult:
  "ani(x⇧^ω * y) = ani(x⇧^ω)"
  by (simp add: an_omega_mult ani_def)

lemma ani_star_left_unfold:
  "ani(x⇧^⋆) = ani(x * x⇧^⋆)"
  by (simp add: an_star_left_unfold ani_def)

lemma an_star_import:
  "an(y) * x ≤ x * an(y) ⟹ an(y) * x⇧^⋆ = an(y) * (an(y) * x)⇧^⋆"
  by (metis an_n_def n_star_import)

lemma an_omega_export:
  "an(y) * x ≤ x * an(y) ⟹ an(y) * x⇧^ω = (an(y) * x)⇧^ω"
  by (metis an_n_def n_omega_export)

lemma an_omega_import:
  "an(y) * x ≤ x * an(y) ⟹ an(y) * x⇧^ω = an(y) * (an(y) * x)⇧^ω"
  by (simp add: an_mult_idempotent omega_import)

end

text ‹Theorem 22›

sublocale an_omega_algebra < nL_omega: an_itering where circ = Omega
  apply unfold_locales
  by (rule while_Omega_def)

context an_omega_algebra
begin

lemma preserves_star:
  "nL_omega.preserves x (-p) ⟹ nL_omega.preserves (x⇧^⋆) (-p)"
  by (simp add: nL_omega.preserves_def star.circ_simulate)

end

end

Theory N_Semirings_Modal

(* Title:      Modal N-Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Modal N-Semirings›

theory N_Semirings_Modal

imports N_Semirings_Boolean

begin

class n_diamond_semiring = n_semiring + diamond +
  assumes ndiamond_def: "|x>y = n(x * y * L)"
begin

lemma diamond_x_bot:
  "|x>bot = n(x)"
  using n_mult_bot ndiamond_def mult_assoc by auto

lemma diamond_x_1:
  "|x>1 = n(x * L)"
  by (simp add: ndiamond_def)

lemma diamond_x_L:
  "|x>L = n(x * L)"
  by (simp add: L_left_zero ndiamond_def mult_assoc)

lemma diamond_x_top:
  "|x>top = n(x * L)"
  by (metis mult_assoc n_top_L ndiamond_def top_mult_top)

lemma diamond_x_n:
  "|x>n(y) = n(x * y)"
  by (simp add: n_mult ndiamond_def)

lemma diamond_bot_y:
  "|bot>y = bot"
  by (simp add: n_bot ndiamond_def)

lemma diamond_1_y:
  "|1>y = n(y * L)"
  by (simp add: ndiamond_def)

lemma diamond_1_n:
  "|1>n(y) = n(y)"
  by (simp add: diamond_1_y n_n_L)

lemma diamond_L_y:
  "|L>y = 1"
  by (simp add: L_left_zero n_L ndiamond_def)

lemma diamond_top_y:
  "|top>y = 1"
  by (metis sup_left_top sup_right_top diamond_L_y mult_right_dist_sup n_dist_sup n_top ndiamond_def)

lemma diamond_n_y:
  "|n(x)>y = n(x) * n(y * L)"
  by (simp add: n_export ndiamond_def mult_assoc)

lemma diamond_n_bot:
  "|n(x)>bot = bot"
  by (simp add: n_bot n_mult_right_bot ndiamond_def)

lemma diamond_n_1:
  "|n(x)>1 = n(x)"
  using diamond_1_n diamond_1_y diamond_x_1 by auto

lemma diamond_n_n:
  "|n(x)>n(y) = n(x) * n(y)"
  by (simp add: diamond_x_n n_export)

lemma diamond_n_n_same:
  "|n(x)>n(x) = n(x)"
  by (simp add: diamond_n_n n_mult_idempotent)

text ‹Theorem 23.1›

lemma diamond_left_dist_sup:
  "|x ⊔ y>z = |x>z ⊔ |y>z"
  by (simp add: mult_right_dist_sup n_dist_sup ndiamond_def)

text ‹Theorem 23.2›

lemma diamond_right_dist_sup:
  "|x>(y ⊔ z) = |x>y ⊔ |x>z"
  by (simp add: mult_left_dist_sup n_dist_sup ndiamond_def semiring.distrib_right)

text ‹Theorem 23.3›

lemma diamond_associative:
  "|x * y>z = |x>(y * z)"
  by (simp add: ndiamond_def mult_assoc)

text ‹Theorem 23.3›

lemma diamond_left_mult:
  "|x * y>z = |x>|y>z"
  using n_mult_ni ndiamond_def ni_def mult_assoc by auto

lemma diamond_right_mult:
  "|x>(y * z) = |x>|y>z"
  using diamond_associative diamond_left_mult by force

lemma diamond_n_export:
  "|n(x) * y>z = n(x) * |y>z"
  by (simp add: n_export ndiamond_def mult_assoc)

lemma diamond_diamond_export:
  "||x>y>z = |x>y * |z>1"
  using diamond_n_y ndiamond_def by auto

lemma diamond_left_isotone:
  "x ≤ y ⟹ |x>z ≤ |y>z"
  by (metis diamond_left_dist_sup le_iff_sup)

lemma diamond_right_isotone:
  "y ≤ z ⟹ |x>y ≤ |x>z"
  by (metis diamond_right_dist_sup le_iff_sup)

lemma diamond_isotone:
  "w ≤ y ⟹ x ≤ z ⟹ |w>x ≤ |y>z"
  by (meson diamond_left_isotone diamond_right_isotone order_trans)

definition ndiamond_L :: "'a ⇒ 'a ⇒ 'a" ("∥ _ » _" [50,90] 95)
  where "∥x»y ≡ n(x * y) * L"

lemma ndiamond_to_L:
  "∥x»y = |x>n(y) * L"
  by (simp add: diamond_x_n ndiamond_L_def)

lemma ndiamond_from_L:
  "|x>y = n(∥x»(y * L))"
  by (simp add: n_n_L ndiamond_def mult_assoc ndiamond_L_def)

lemma diamond_L_ni:
  "∥x»y = ni(x * y)"
  by (simp add: ni_def ndiamond_L_def)

lemma diamond_L_associative:
  "∥x * y»z = ∥x»(y * z)"
  by (simp add: diamond_L_ni mult_assoc)

lemma diamond_L_left_mult:
  "∥x * y»z = ∥x»∥y»z"
  using diamond_L_associative diamond_L_ni ni_mult by auto

lemma diamond_L_right_mult:
  "∥x»(y * z) = ∥x»∥y»z"
  using diamond_L_associative diamond_L_left_mult by auto

lemma diamond_L_left_dist_sup:
  "∥x ⊔ y»z = ∥x»z ⊔ ∥y»z"
  by (simp add: diamond_L_ni mult_right_dist_sup ni_dist_sup)

lemma diamond_L_x_ni:
  "∥x»ni(y) = ni(x * y)"
  using n_mult_ni ni_def ndiamond_L_def by auto

lemma diamond_L_left_isotone:
  "x ≤ y ⟹ ∥x»z ≤ ∥y»z"
  using mult_left_isotone ni_def ni_isotone ndiamond_L_def by auto

lemma diamond_L_right_isotone:
  "y ≤ z ⟹ ∥x»y ≤ ∥x»z"
  using mult_right_isotone ni_def ni_isotone ndiamond_L_def by auto

lemma diamond_L_isotone:
  "w ≤ y ⟹ x ≤ z ⟹ ∥w»x ≤ ∥y»z"
  using diamond_L_ni mult_isotone ni_isotone by force

end

class n_box_semiring = n_diamond_semiring + an_semiring + box +
  assumes nbox_def: "|x]y = an(x * an(y * L) * L)"
begin

text ‹Theorem 23.8›

lemma box_diamond:
  "|x]y = an( |x>an(y * L) * L)"
  by (simp add: an_n_L nbox_def ndiamond_def)

text ‹Theorem 23.4›

lemma diamond_box:
  "|x>y = an( |x]an(y * L) * L)"
  using n_an_def n_mult nbox_def ndiamond_def mult_assoc by force

lemma box_x_bot:
  "|x]bot = an(x * L)"
  by (simp add: an_bot nbox_def)

lemma box_x_1:
  "|x]1 = an(x)"
  using an_L an_mult_an nbox_def mult_assoc by auto

lemma box_x_L:
  "|x]L = an(x)"
  using box_x_1 L_left_zero nbox_def by auto

lemma box_x_top:
  "|x]top = an(x)"
  by (metis box_diamond box_x_1 box_x_bot diamond_top_y)

lemma box_x_n:
  "|x]n(y) = an(x * an(y) * L)"
  by (simp add: an_n_L nbox_def)

lemma box_x_an:
  "|x]an(y) = an(x * y)"
  using an_mult n_an_def nbox_def by auto

lemma box_bot_y:
  "|bot]y = 1"
  by (simp add: an_bot nbox_def)

lemma box_1_y:
  "|1]y = n(y * L)"
  by (simp add: n_an_def nbox_def)

lemma box_1_n:
  "|1]n(y) = n(y)"
  using box_1_y diamond_1_n diamond_1_y by auto

lemma box_1_an:
  "|1]an(y) = an(y)"
  by (simp add: box_x_an)

lemma box_L_y:
  "|L]y = bot"
  by (simp add: L_left_zero an_L nbox_def)

lemma box_top_y:
  "|top]y = bot"
  by (simp add: box_diamond an_L diamond_top_y)

lemma box_n_y:
  "|n(x)]y = an(x) ⊔ n(y * L)"
  using an_export_n n_an_def nbox_def mult_assoc by auto

lemma box_an_y:
  "|an(x)]y = n(x) ⊔ n(y * L)"
  by (metis an_n_def box_n_y n_an_def)

lemma box_n_bot:
  "|n(x)]bot = an(x)"
  by (simp add: box_x_bot an_n_L)

lemma box_an_bot:
  "|an(x)]bot = n(x)"
  by (simp add: box_x_bot n_an_def)

lemma box_n_1:
  "|n(x)]1 = 1"
  using box_x_1 ani_an_L ani_n by auto

lemma box_an_1:
  "|an(x)]1 = 1"
  using box_x_1 ani_an ani_an_L by fastforce

lemma box_n_n:
  "|n(x)]n(y) = an(x) ⊔ n(y)"
  using box_1_n box_1_y box_n_y by auto

lemma box_an_n:
  "|an(x)]n(y) = n(x) ⊔ n(y)"
  using box_x_n an_dist_sup n_an_def n_dist_sup by auto

lemma box_n_an:
  "|n(x)]an(y) = an(x) ⊔ an(y)"
  by (simp add: box_x_an an_export_n)

lemma box_an_an:
  "|an(x)]an(y) = n(x) ⊔ an(y)"
  by (simp add: box_x_an an_export)

lemma box_n_n_same:
  "|n(x)]n(x) = 1"
  by (simp add: box_n_n an_complement)

lemma box_an_an_same:
  "|an(x)]an(x) = 1"
  using box_an_bot an_bot an_complement_bot nbox_def by auto

text ‹Theorem 23.5›

lemma box_left_dist_sup:
  "|x ⊔ y]z = |x]z * |y]z"
  using an_dist_sup nbox_def semiring.distrib_right by auto

lemma box_right_dist_sup:
  "|x](y ⊔ z) = an(x * an(y * L) * an(z * L) * L)"
  by (simp add: an_dist_sup mult_right_dist_sup nbox_def mult_assoc)

lemma box_associative:
  "|x * y]z = an(x * y * an(z * L) * L)"
  by (simp add: nbox_def)

text ‹Theorem 23.7›

lemma box_left_mult:
  "|x * y]z = |x]|y]z"
  using box_x_an nbox_def mult_assoc by auto

lemma box_right_mult:
  "|x](y * z) = an(x * an(y * z * L) * L)"
  by (simp add: nbox_def)

text ‹Theorem 23.6›

lemma box_right_mult_n_n:
  "|x](n(y) * n(z)) = |x]n(y) * |x]n(z)"
  by (smt an_dist_sup an_export_n an_n_L mult_assoc mult_left_dist_sup mult_right_dist_sup nbox_def)

lemma box_right_mult_an_n:
  "|x](an(y) * n(z)) = |x]an(y) * |x]n(z)"
  by (metis an_n_def box_right_mult_n_n)

lemma box_right_mult_n_an:
  "|x](n(y) * an(z)) = |x]n(y) * |x]an(z)"
  by (simp add: box_right_mult_an_n box_x_an box_x_n an_mult_commutative n_an_mult_commutative)

lemma box_right_mult_an_an:
  "|x](an(y) * an(z)) = |x]an(y) * |x]an(z)"
  by (metis an_dist_sup box_x_an mult_left_dist_sup)

lemma box_n_export:
  "|n(x) * y]z = an(x) ⊔ |y]z"
  using box_left_mult box_n_an nbox_def by auto

lemma box_an_export:
  "|an(x) * y]z = n(x) ⊔ |y]z"
  using box_an_an box_left_mult nbox_def by auto

lemma box_left_antitone:
  "y ≤ x ⟹ |x]z ≤ |y]z"
  by (smt an_mult_commutative an_order box_diamond box_left_dist_sup le_iff_sup)

lemma box_right_isotone:
  "y ≤ z ⟹ |x]y ≤ |x]z"
  by (metis an_antitone mult_left_isotone mult_right_isotone nbox_def)

lemma box_antitone_isotone:
  "y ≤ w ⟹ x ≤ z ⟹ |w]x ≤ |y]z"
  by (meson box_left_antitone box_right_isotone order.trans)

definition nbox_L :: "'a ⇒ 'a ⇒ 'a" ("∥ _ ⟧ _" [50,90] 95)
  where "∥x⟧y ≡ an(x * an(y) * L) * L"

lemma nbox_to_L:
  "∥x⟧y = |x]n(y) * L"
  by (simp add: box_x_n nbox_L_def)

lemma nbox_from_L:
  "|x]y = n(∥x⟧(y * L))"
  using an_n_def nbox_def nbox_L_def by auto

lemma diamond_x_an:
  "|x>an(y) = n(x * an(y) * L)"
  by (simp add: ndiamond_def)

lemma diamond_1_an:
  "|1>an(y) = an(y)"
  using box_1_an box_1_y diamond_1_y by auto

lemma diamond_an_y:
  "|an(x)>y = an(x) * n(y * L)"
  by (simp add: n_export_an ndiamond_def mult_assoc)

lemma diamond_an_bot:
  "|an(x)>bot = bot"
  by (simp add: an_mult_right_zero n_bot ndiamond_def)

lemma diamond_an_1:
  "|an(x)>1 = an(x)"
  using an_n_def diamond_x_1 by auto

lemma diamond_an_n:
  "|an(x)>n(y) = an(x) * n(y)"
  by (simp add: diamond_x_n n_export_an)

lemma diamond_n_an:
  "|n(x)>an(y) = n(x) * an(y)"
  using an_n_def diamond_n_y by auto

lemma diamond_an_an:
  "|an(x)>an(y) = an(x) * an(y)"
  using diamond_an_y an_n_def by auto

lemma diamond_an_an_same:
  "|an(x)>an(x) = an(x)"
  by (simp add: diamond_an_an an_mult_idempotent)

lemma diamond_an_export:
  "|an(x) * y>z = an(x) * |y>z"
  using diamond_an_an diamond_box diamond_left_mult by auto

lemma box_ani:
  "|x]y = an(x * ani(y * L))"
  by (simp add: ani_def nbox_def mult_assoc)

lemma box_x_n_ani:
  "|x]n(y) = an(x * ani(y))"
  by (simp add: box_x_n ani_def mult_assoc)

lemma box_L_ani:
  "∥x⟧y = ani(x * ani(y))"
  using box_x_n_ani ani_def nbox_to_L by auto

lemma box_L_left_mult:
  "∥x * y⟧z = ∥x⟧∥y⟧z"
  using an_mult n_an_def mult_assoc nbox_L_def by auto

lemma diamond_x_an_ani:
  "|x>an(y) = n(x * ani(y))"
  by (simp add: ani_def ndiamond_def mult_assoc)

lemma box_L_left_antitone:
  "y ≤ x ⟹ ∥x⟧z ≤ ∥y⟧z"
  by (simp add: box_L_ani ani_antitone mult_left_isotone)

lemma box_L_right_isotone:
  "y ≤ z ⟹ ∥x⟧y ≤ ∥x⟧z"
  using ani_antitone ani_def mult_right_isotone mult_assoc nbox_L_def by auto

lemma box_L_antitone_isotone:
  "y ≤ w ⟹ x ≤ z ⟹ ∥w⟧x ≤ ∥y⟧z"
  using ani_antitone ani_def mult_isotone mult_assoc nbox_L_def by force

end

class n_box_omega_algebra = n_box_semiring + an_omega_algebra
begin

lemma diamond_omega:
  "|x⇧^ω>y = |x⇧^ω>z"
  by (simp add: n_omega_mult ndiamond_def mult_assoc)

lemma box_omega:
  "|x⇧^ω]y = |x⇧^ω]z"
  by (metis box_diamond diamond_omega)

lemma an_box_omega_induct:
  "|x]an(y) * n(z * L) ≤ an(y) ⟹ |x⇧^ω ⊔ x⇧^⋆]z ≤ an(y)"
  by (smt an_dist_sup an_omega_induct an_omega_mult box_left_dist_sup box_x_an mult_assoc n_an_def nbox_def)

lemma n_box_omega_induct:
  "|x]n(y) * n(z * L) ≤ n(y) ⟹ |x⇧^ω ⊔ x⇧^⋆]z ≤ n(y)"
  by (simp add: an_box_omega_induct n_an_def)

lemma an_box_omega_induct_an:
  "|x]an(y) * an(z) ≤ an(y) ⟹ |x⇧^ω ⊔ x⇧^⋆]an(z) ≤ an(y)"
  using an_box_omega_induct an_n_def by auto

text ‹Theorem 23.13›

lemma n_box_omega_induct_n:
  "|x]n(y) * n(z) ≤ n(y) ⟹ |x⇧^ω ⊔ x⇧^⋆]n(z) ≤ n(y)"
  using an_box_omega_induct_an n_an_def by force

lemma n_diamond_omega_induct:
  "n(y) ≤ |x>n(y) ⊔ n(z * L) ⟹ n(y) ≤ |x⇧^ω ⊔ x⇧^⋆>z"
  using diamond_x_n mult_right_dist_sup n_dist_sup n_omega_induct n_omega_mult ndiamond_def mult_assoc by force

lemma an_diamond_omega_induct:
  "an(y) ≤ |x>an(y) ⊔ n(z * L) ⟹ an(y) ≤ |x⇧^ω ⊔ x⇧^⋆>z"
  by (metis n_diamond_omega_induct an_n_def)

text ‹Theorem 23.9›

lemma n_diamond_omega_induct_n:
  "n(y) ≤ |x>n(y) ⊔ n(z) ⟹ n(y) ≤ |x⇧^ω ⊔ x⇧^⋆>n(z)"
  using box_1_n box_1_y n_diamond_omega_induct by auto

lemma an_diamond_omega_induct_an:
  "an(y) ≤ |x>an(y) ⊔ an(z) ⟹ an(y) ≤ |x⇧^ω ⊔ x⇧^⋆>an(z)"
  using an_diamond_omega_induct an_n_def by auto

lemma box_segerberg_an:
  "|x⇧^ω ⊔ x⇧^⋆]an(y) = an(y) * |x⇧^ω ⊔ x⇧^⋆](n(y) ⊔ |x]an(y))"
proof (rule order.antisym)
  have "|x⇧^ω ⊔ x⇧^⋆]an(y) ≤ |x⇧^ω ⊔ x⇧^⋆]|x]an(y)"
    by (smt box_left_dist_sup box_left_mult box_omega sup_right_isotone box_left_antitone mult_right_dist_sup star.right_plus_below_circ)
  hence "|x⇧^ω ⊔ x⇧^⋆]an(y) ≤ |x⇧^ω ⊔ x⇧^⋆](n(y) ⊔ |x]an(y))"
    using box_right_isotone order_lesseq_imp sup.cobounded2 by blast
  thus"|x⇧^ω ⊔ x⇧^⋆]an(y) ≤ an(y) * |x⇧^ω ⊔ x⇧^⋆](n(y) ⊔ |x]an(y))"
    by (metis le_sup_iff box_1_an box_left_antitone order_refl star_left_unfold_equal an_mult_least_upper_bound nbox_def)
next
  have "an(y) * |x](n(y) ⊔ |x⇧^ω ⊔ x⇧^⋆]an(y)) * (n(y) ⊔ |x]an(y)) = |x]( |x⇧^ω ⊔ x⇧^⋆]an(y) * an(y)) * an(y)"
    by (smt sup_bot_left an_export an_mult_commutative box_right_mult_an_an mult_assoc mult_right_dist_sup n_complement_bot nbox_def)
  hence 1: "an(y) * |x](n(y) ⊔ |x⇧^ω ⊔ x⇧^⋆]an(y)) * (n(y) ⊔ |x]an(y)) ≤ n(y) ⊔ |x⇧^ω ⊔ x⇧^⋆]an(y)"
    by (smt sup_assoc sup_commute sup_ge2 box_1_an box_left_dist_sup box_left_mult mult_left_dist_sup omega_unfold star_left_unfold_equal star.circ_plus_one)
  have "n(y) * |x](n(y) ⊔ |x⇧^ω ⊔ x⇧^⋆]an(y)) * (n(y) ⊔ |x]an(y)) ≤ n(y) ⊔ |x⇧^ω ⊔ x⇧^⋆]an(y)"
    by (smt sup_ge1 an_n_def mult_left_isotone n_an_mult_left_lower_bound n_mult_left_absorb_sup nbox_def order_trans)
  thus "an(y) * |x⇧^ω ⊔ x⇧^⋆](n(y) ⊔ |x]an(y)) ≤ |x⇧^ω ⊔ x⇧^⋆]an(y)"
    using 1 by (smt an_case_split_left an_shunting_an mult_assoc n_box_omega_induct_n n_dist_sup nbox_def nbox_from_L)
qed

text ‹Theorem 23.16›

lemma box_segerberg_n:
  "|x⇧^ω ⊔ x⇧^⋆]n(y) = n(y) * |x⇧^ω ⊔ x⇧^⋆](an(y) ⊔ |x]n(y))"
  using box_segerberg_an an_n_def n_an_def by force

lemma diamond_segerberg_an:
  "|x⇧^ω ⊔ x⇧^⋆>an(y) = an(y) ⊔ |x⇧^ω ⊔ x⇧^⋆>(n(y) * |x>an(y))"
  by (smt an_export an_n_L box_diamond box_segerberg_an diamond_box mult_assoc n_an_def)

text ‹Theorem 23.12›

lemma diamond_segerberg_n:
  "|x⇧^ω ⊔ x⇧^⋆>n(y) = n(y) ⊔ |x⇧^ω ⊔ x⇧^⋆>(an(y) * |x>n(y))"
  using diamond_segerberg_an an_n_L n_an_def by auto

text ‹Theorem 23.11›

lemma diamond_star_unfold_n:
  "|x⇧^⋆>n(y) = n(y) ⊔ |an(y) * x>|x⇧^⋆>n(y)"
proof -
  have "|x⇧^⋆>n(y) = n(y) ⊔ n(y) * |x * x⇧^⋆>n(y) ⊔ |an(y) * x * x⇧^⋆>n(y)"
    by (smt sup_assoc sup_commute sup_bot_right an_complement an_complement_bot diamond_an_n diamond_left_dist_sup diamond_n_export diamond_n_n_same mult_assoc mult_left_one mult_right_dist_sup star_left_unfold_equal)
  thus ?thesis
    by (metis diamond_left_mult diamond_x_n n_sup_left_absorb_mult)
qed

lemma diamond_star_unfold_an:
  "|x⇧^⋆>an(y) = an(y) ⊔ |n(y) * x>|x⇧^⋆>an(y)"
  by (metis an_n_def diamond_star_unfold_n n_an_def)

text ‹Theorem 23.15›

lemma box_star_unfold_n:
  "|x⇧^⋆]n(y) = n(y) * |n(y) * x]|x⇧^⋆]n(y)"
  by (smt an_export an_n_L box_diamond diamond_box diamond_star_unfold_an n_an_def n_export)

lemma box_star_unfold_an:
  "|x⇧^⋆]an(y) = an(y) * |an(y) * x]|x⇧^⋆]an(y)"
  by (metis an_n_def box_star_unfold_n)

text ‹Theorem 23.10›

lemma diamond_omega_unfold_n:
  "|x⇧^ω ⊔ x⇧^⋆>n(y) = n(y) ⊔ |an(y) * x>|x⇧^ω ⊔ x⇧^⋆>n(y)"
  by (smt sup_assoc sup_commute diamond_an_export diamond_left_dist_sup diamond_right_dist_sup diamond_star_unfold_n diamond_x_n n_omega_mult n_plus_complement_intro_n omega_unfold)

lemma diamond_omega_unfold_an:
  "|x⇧^ω ⊔ x⇧^⋆>an(y) = an(y) ⊔ |n(y) * x>|x⇧^ω ⊔ x⇧^⋆>an(y)"
  by (metis an_n_def diamond_omega_unfold_n n_an_def)

text ‹Theorem 23.14›

lemma box_omega_unfold_n:
  "|x⇧^ω ⊔ x⇧^⋆]n(y) = n(y) * |n(y) * x]|x⇧^ω ⊔ x⇧^⋆]n(y)"
  by (smt an_export an_n_L box_diamond diamond_box diamond_omega_unfold_an n_an_def n_export)

lemma box_omega_unfold_an:
  "|x⇧^ω ⊔ x⇧^⋆]an(y) = an(y) * |an(y) * x]|x⇧^ω ⊔ x⇧^⋆]an(y)"
  by (metis an_n_def box_omega_unfold_n)

lemma box_cut_iteration_an:
  "|x⇧^ω ⊔ x⇧^⋆]an(y) = |(an(y) * x)⇧^ω ⊔ (an(y) * x)⇧^⋆]an(y)"
  apply (rule order.antisym)
  apply (meson semiring.add_mono an_case_split_left box_left_antitone omega_isotone order_refl star.circ_isotone)
  by (smt (z3) an_box_omega_induct_an an_mult_commutative box_omega_unfold_an nbox_def order_refl)

lemma box_cut_iteration_n:
  "|x⇧^ω ⊔ x⇧^⋆]n(y) = |(n(y) * x)⇧^ω ⊔ (n(y) * x)⇧^⋆]n(y)"
  using box_cut_iteration_an n_an_def by auto

lemma diamond_cut_iteration_an:
  "|x⇧^ω ⊔ x⇧^⋆>an(y) = |(n(y) * x)⇧^ω ⊔ (n(y) * x)⇧^⋆>an(y)"
  using box_cut_iteration_n diamond_box n_an_def by auto

lemma diamond_cut_iteration_n:
  "|x⇧^ω ⊔ x⇧^⋆>n(y) = |(an(y) * x)⇧^ω ⊔ (an(y) * x)⇧^⋆>n(y)"
  using box_cut_iteration_an an_n_L diamond_box by auto

lemma ni_diamond_omega_induct:
  "ni(y) ≤ ∥x»ni(y) ⊔ ni(z) ⟹ ni(y) ≤ ∥x⇧^ω ⊔ x⇧^⋆»z"
  by (metis diamond_L_left_dist_sup diamond_L_x_ni diamond_L_ni ni_dist_sup ni_omega_induct ni_omega_mult)

lemma ani_diamond_omega_induct:
  "ani(y) ≤ ∥x»ani(y) ⊔ ni(z) ⟹ ani(y) ≤ ∥x⇧^ω ⊔ x⇧^⋆»z"
  by (metis ni_ani ni_diamond_omega_induct)

lemma n_diamond_omega_L:
  "|n(x⇧^ω) * L>y = |x⇧^ω>y"
  using L_left_zero mult_1_right n_L n_export n_omega_mult ndiamond_def mult_assoc by auto

lemma n_diamond_loop:
  "|x⇧^Ω>y = |x⇧^ω ⊔ x⇧^⋆>y"
  by (metis Omega_def diamond_left_dist_sup n_diamond_omega_L)

text ‹Theorem 24.1›

lemma cut_iteration_loop:
  "|x⇧^Ω>n(y) = |(an(y) * x)⇧^Ω>n(y)"
  using diamond_cut_iteration_n n_diamond_loop by auto

lemma cut_iteration_while_loop:
  "|x⇧^Ω>n(y) = |(an(y) * x)⇧^Ω * n(y)>n(y)"
  using cut_iteration_loop diamond_left_mult diamond_n_n_same by auto

text ‹Theorem 24.1›

lemma cut_iteration_while_loop_2:
  "|x⇧^Ω>n(y) = |an(y) ⋆ x>n(y)"
  by (metis cut_iteration_while_loop an_uminus n_an_def while_Omega_def)

lemma modal_while:
  assumes "-q * -p * L ≤ x * -p * L ∧ -p ≤ -q ⊔ -r"
    shows "-p ≤ |n((-q * x)⇧^ω) * L ⊔ (-q * x)⇧^⋆ * --q>(-r)"
proof -
  have 1: "--q * -p ≤ |-q * x>(-p) ⊔ --q * -r"
    using assms mult_right_isotone sup.coboundedI2 tests_dual.sup_complement_intro by auto
  have "-q * -p = n(-q * -q * -p * L)"
    using an_uminus n_export_an mult_assoc mult_1_right n_L tests_dual.sup_idempotent by auto
  also have "... ≤ n(-q * x * -p * L)"
    by (metis assms n_isotone mult_right_isotone mult_assoc)
  also have "... ≤ |-q * x>(-p) ⊔ --q * -r"
    by (simp add: ndiamond_def)
  finally have "-p ≤ |-q * x>(-p) ⊔ --q * -r"
    using 1 by (smt sup_assoc le_iff_sup tests_dual.inf_cases sub_comm)
  thus ?thesis
    by (smt L_left_zero an_diamond_omega_induct_an an_uminus diamond_left_dist_sup mult_assoc n_n_L n_omega_mult ndiamond_def sub_mult_closed)
qed

lemma modal_while_loop:
  "-q * -p * L ≤ x * -p * L ∧ -p ≤ -q ⊔ -r ⟹ -p ≤ |(-q * x)⇧^Ω * --q>(-r)"
  by (metis L_left_zero Omega_def modal_while mult_assoc mult_right_dist_sup)

text ‹Theorem 24.2›

lemma modal_while_loop_2:
  "-q * -p * L ≤ x * -p * L ∧ -p ≤ -q ⊔ -r ⟹ -p ≤ |-q ⋆ x>(-r)"
  by (simp add: while_Omega_def modal_while_loop)

lemma modal_while_2:
  assumes "-p * L ≤ x * -p * L"
    shows "-p ≤ |n((-q * x)⇧^ω) * L ⊔ (-q * x)⇧^⋆ * --q>(--q)"
proof -
  have "-p ≤ |-q * x>(-p) ⊔ --q"
    by (smt (verit, del_insts) assms an_uminus tests_dual.double_negation n_an_def n_isotone ndiamond_def diamond_an_export sup_assoc sup_commute le_iff_sup tests_dual.inf_complement_intro)
  thus ?thesis
    by (smt L_left_zero an_diamond_omega_induct_an an_uminus diamond_left_dist_sup mult_assoc tests_dual.sup_idempotent n_n_L n_omega_mult ndiamond_def)
qed

end

class n_modal_omega_algebra = n_box_omega_algebra +
  assumes n_star_induct: "n(x * y) ≤ n(y) ⟶ n(x⇧^⋆ * y) ≤ n(y)"
begin

lemma n_star_induct_sup:
  "n(z ⊔ x * y) ≤ n(y) ⟹ n(x⇧^⋆ * z) ≤ n(y)"
  by (metis an_dist_sup an_mult_least_upper_bound an_n_order n_mult_right_upper_bound n_star_induct star_L_split)

lemma n_star_induct_star:
  "n(x * y) ≤ n(y) ⟹ n(x⇧^⋆) ≤ n(y)"
  using n_star_induct n_star_mult by auto

lemma n_star_induct_iff:
  "n(x * y) ≤ n(y) ⟷ n(x⇧^⋆ * y) ≤ n(y)"
  by (metis mult_left_isotone n_isotone n_star_induct order_trans star.circ_increasing)

lemma n_star_bot:
  "n(x) = bot ⟷ n(x⇧^⋆) = bot"
  by (metis sup_bot_right le_iff_sup mult_1_right n_one n_star_induct_iff)

lemma n_diamond_star_induct:
  "|x>n(y) ≤ n(y) ⟹ |x⇧^⋆>n(y) ≤ n(y)"
  by (simp add: diamond_x_n n_star_induct)

lemma n_diamond_star_induct_sup:
  "|x>n(y) ⊔ n(z) ≤ n(y) ⟹ |x⇧^⋆>n(z) ≤ n(y)"
  by (simp add: diamond_x_n n_dist_sup n_star_induct_sup)

lemma n_diamond_star_induct_iff:
  "|x>n(y) ≤ n(y) ⟷ |x⇧^⋆>n(y) ≤ n(y)"
  using diamond_x_n n_star_induct_iff by auto

lemma an_star_induct:
  "an(y) ≤ an(x * y) ⟹ an(y) ≤ an(x⇧^⋆ * y)"
  using an_n_order n_star_induct by auto

lemma an_star_induct_sup:
  "an(y) ≤ an(z ⊔ x * y) ⟹ an(y) ≤ an(x⇧^⋆ * z)"
  using an_n_order n_star_induct_sup by auto

lemma an_star_induct_star:
  "an(y) ≤ an(x * y) ⟹ an(y) ≤ an(x⇧^⋆)"
  by (simp add: an_n_order n_star_induct_star)

lemma an_star_induct_iff:
  "an(y) ≤ an(x * y) ⟷ an(y) ≤ an(x⇧^⋆ * y)"
  using an_n_order n_star_induct_iff by auto

lemma an_star_one:
  "an(x) = 1 ⟷ an(x⇧^⋆) = 1"
  by (metis an_n_equal an_bot n_star_bot n_bot)

lemma an_box_star_induct:
  "an(y) ≤ |x]an(y) ⟹ an(y) ≤ |x⇧^⋆]an(y)"
  by (simp add: an_star_induct box_x_an)

lemma an_box_star_induct_sup:
  "an(y) ≤ |x]an(y) * an(z) ⟹ an(y) ≤ |x⇧^⋆]an(z)"
  by (simp add: an_star_induct_sup an_dist_sup an_mult_commutative box_x_an)

lemma an_box_star_induct_iff:
  "an(y) ≤ |x]an(y) ⟷ an(y) ≤ |x⇧^⋆]an(y)"
  using an_star_induct_iff box_x_an by auto

lemma box_star_segerberg_an:
  "|x⇧^⋆]an(y) = an(y) * |x⇧^⋆](n(y) ⊔ |x]an(y))"
proof (rule order.antisym)
  show "|x⇧^⋆]an(y) ≤ an(y) * |x⇧^⋆](n(y) ⊔ |x]an(y))"
    by (smt (verit) sup_ge2 box_1_an box_left_dist_sup box_left_mult box_right_isotone mult_right_isotone star.circ_right_unfold)
next
  have "an(y) * |x⇧^⋆](n(y) ⊔ |x]an(y)) ≤ an(y) * |x]an(y)"
    by (metis sup_bot_left an_complement_bot box_an_an box_left_antitone box_x_an mult_left_dist_sup mult_left_one mult_right_isotone star.circ_reflexive)
  thus "an(y) * |x⇧^⋆](n(y) ⊔ |x]an(y)) ≤ |x⇧^⋆]an(y)"
    by (smt an_box_star_induct_sup an_case_split_left an_dist_sup an_mult_least_upper_bound box_left_antitone box_left_mult box_right_mult_an_an star.left_plus_below_circ nbox_def)
qed

lemma box_star_segerberg_n:
  "|x⇧^⋆]n(y) = n(y) * |x⇧^⋆](an(y) ⊔ |x]n(y))"
  using box_star_segerberg_an an_n_def n_an_def by auto

lemma diamond_segerberg_an:
  "|x⇧^⋆>an(y) = an(y) ⊔ |x⇧^⋆>(n(y) * |x>an(y))"
  by (smt an_export an_n_L box_diamond box_star_segerberg_an diamond_box mult_assoc n_an_def)

lemma diamond_star_segerberg_n:
  "|x⇧^⋆>n(y) = n(y) ⊔ |x⇧^⋆>(an(y) * |x>n(y))"
  using an_n_def diamond_segerberg_an n_an_def by auto

lemma box_cut_star_iteration_an:
  "|x⇧^⋆]an(y) = |(an(y) * x)⇧^⋆]an(y)"
  by (smt an_box_star_induct_sup an_mult_commutative an_mult_complement_intro_an order.antisym box_an_export box_star_unfold_an nbox_def order_refl)

lemma box_cut_star_iteration_n:
  "|x⇧^⋆]n(y) = |(n(y) * x)⇧^⋆]n(y)"
  using box_cut_star_iteration_an n_an_def by auto

lemma diamond_cut_star_iteration_an:
  "|x⇧^⋆>an(y) = |(n(y) * x)⇧^⋆>an(y)"
  using box_cut_star_iteration_an diamond_box n_an_def by auto

lemma diamond_cut_star_iteration_n:
  "|x⇧^⋆>n(y) = |(an(y) * x)⇧^⋆>n(y)"
  using box_cut_star_iteration_an an_n_L diamond_box by auto

lemma ni_star_induct:
  "ni(x * y) ≤ ni(y) ⟹ ni(x⇧^⋆ * y) ≤ ni(y)"
  using n_star_induct ni_n_order by auto

lemma ni_star_induct_sup:
  "ni(z ⊔ x * y) ≤ ni(y) ⟹ ni(x⇧^⋆ * z) ≤ ni(y)"
  by (simp add: ni_n_order n_star_induct_sup)

lemma ni_star_induct_star:
  "ni(x * y) ≤ ni(y) ⟹ ni(x⇧^⋆) ≤ ni(y)"
  using ni_n_order n_star_induct_star by auto

lemma ni_star_induct_iff:
  "ni(x * y) ≤ ni(y) ⟷ ni(x⇧^⋆ * y) ≤ ni(y)"
  using ni_n_order n_star_induct_iff by auto

lemma ni_star_bot:
  "ni(x) = bot ⟷ ni(x⇧^⋆) = bot"
  using ni_n_bot n_star_bot by auto

lemma ni_diamond_star_induct:
  "∥x»ni(y) ≤ ni(y) ⟹ ∥x⇧^⋆»ni(y) ≤ ni(y)"
  by (simp add: diamond_L_x_ni ni_star_induct)

lemma ni_diamond_star_induct_sup:
  "∥x»ni(y) ⊔ ni(z) ≤ ni(y) ⟹ ∥x⇧^⋆»ni(z) ≤ ni(y)"
  by (simp add: diamond_L_x_ni ni_dist_sup ni_star_induct_sup)

lemma ni_diamond_star_induct_iff:
  "∥x»ni(y) ≤ ni(y) ⟷ ∥x⇧^⋆»ni(y) ≤ ni(y)"
  using diamond_L_x_ni ni_star_induct_iff by auto

lemma ani_star_induct:
  "ani(y) ≤ ani(x * y) ⟹ ani(y) ≤ ani(x⇧^⋆ * y)"
  using an_star_induct ani_an_order by blast

lemma ani_star_induct_sup:
  "ani(y) ≤ ani(z ⊔ x * y) ⟹ ani(y) ≤ ani(x⇧^⋆ * z)"
  by (simp add: an_star_induct_sup ani_an_order)

lemma ani_star_induct_star:
  "ani(y) ≤ ani(x * y) ⟹ ani(y) ≤ ani(x⇧^⋆)"
  using an_star_induct_star ani_an_order by auto

lemma ani_star_induct_iff:
  "ani(y) ≤ ani(x * y) ⟷ ani(y) ≤ ani(x⇧^⋆ * y)"
  using an_star_induct_iff ani_an_order by auto

lemma ani_star_L:
  "ani(x) = L ⟷ ani(x⇧^⋆) = L"
  using an_star_one ani_an_L by auto

lemma ani_box_star_induct:
  "ani(y) ≤ ∥x⟧ani(y) ⟹ ani(y) ≤ ∥x⇧^⋆⟧ani(y)"
  by (metis an_ani ani_def ani_star_induct_iff n_ani box_L_ani)

lemma ani_box_star_induct_iff:
  "ani(y) ≤ ∥x⟧ani(y) ⟷ ani(y) ≤ ∥x⇧^⋆⟧ani(y)"
  using ani_box_star_induct box_L_left_antitone order_lesseq_imp star.circ_increasing by blast

lemma ani_box_star_induct_sup:
  "ani(y) ≤ ∥x⟧ani(y) ⟹ ani(y) ≤ ani(z) ⟹ ani(y) ≤ ∥x⇧^⋆⟧ani(z)"
  by (meson ani_box_star_induct_iff box_L_right_isotone order_trans)

end

end

Theory Approximation

(* Title:      Approximation
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Approximation›

theory Approximation

imports Stone_Kleene_Relation_Algebras.Iterings

begin

class apx =
  fixes apx :: "'a ⇒ 'a ⇒ bool" (infix "⊑" 50)

class apx_order = apx +
  assumes apx_reflexive: "x ⊑ x"
  assumes apx_antisymmetric: "x ⊑ y ∧ y ⊑ x ⟶ x = y"
  assumes apx_transitive: "x ⊑ y ∧ y ⊑ z ⟶ x ⊑ z"

sublocale apx_order < apx: order where less_eq = apx and less = "λx y . x ⊑ y ∧ ¬ y ⊑ x"
  apply unfold_locales
  apply simp
  apply (rule apx_reflexive)
  using apx_transitive apply blast
  by (simp add: apx_antisymmetric)

context apx_order
begin

abbreviation the_apx_least_fixpoint    :: "('a ⇒ 'a) ⇒ 'a" ("κ _" [201] 200)  where "κ  f ≡ apx.the_least_fixpoint f"
abbreviation the_apx_least_prefixpoint :: "('a ⇒ 'a) ⇒ 'a" ("pκ _" [201] 200) where "pκ f ≡ apx.the_least_prefixpoint f"

definition is_apx_meet  :: "'a ⇒ 'a ⇒ 'a ⇒ bool"          where "is_apx_meet x y z ≡ z ⊑ x ∧ z ⊑ y ∧ (∀w . w ⊑ x ∧ w ⊑ y ⟶ w ⊑ z)"
definition has_apx_meet :: "'a ⇒ 'a ⇒ bool"                where "has_apx_meet x y ≡ ∃z . is_apx_meet x y z"
definition the_apx_meet :: "'a ⇒ 'a ⇒ 'a" (infixl "△" 66) where "x △ y ≡ THE z . is_apx_meet x y z"

lemma apx_meet_unique:
  "has_apx_meet x y ⟹ ∃!z . is_apx_meet x y z"
  by (meson apx_antisymmetric has_apx_meet_def is_apx_meet_def)

lemma apx_meet:
  assumes "has_apx_meet x y"
    shows "is_apx_meet x y (x △ y)"
proof -
  have "is_apx_meet x y (THE z . is_apx_meet x y z)"
    by (metis apx_meet_unique assms theI)
  thus ?thesis
    by (simp add: the_apx_meet_def)
qed

lemma apx_greatest_lower_bound:
  "has_apx_meet x y ⟹ (w ⊑ x ∧ w ⊑ y ⟷ w ⊑ x △ y)"
  by (meson apx_meet apx_transitive is_apx_meet_def)

lemma apx_meet_same:
  "is_apx_meet x y z ⟹ z = x △ y"
  using apx_meet apx_meet_unique has_apx_meet_def by blast

lemma apx_meet_char:
  "is_apx_meet x y z ⟷ has_apx_meet x y ∧ z = x △ y"
  using apx_meet_same has_apx_meet_def by auto

end

class apx_biorder = apx_order + order
begin

lemma mu_below_kappa:
  "has_least_fixpoint f ⟹ apx.has_least_fixpoint f ⟹ μ f ≤ κ f"
  using apx.mu_unfold is_least_fixpoint_def least_fixpoint by auto

lemma kappa_below_nu:
  "has_greatest_fixpoint f ⟹ apx.has_least_fixpoint f ⟹ κ f ≤ ν f"
  by (meson apx.mu_unfold greatest_fixpoint is_greatest_fixpoint_def)

lemma kappa_apx_below_mu:
  "has_least_fixpoint f ⟹ apx.has_least_fixpoint f ⟹ κ f ⊑ μ f"
  using apx.is_least_fixpoint_def apx.least_fixpoint mu_unfold by auto

lemma kappa_apx_below_nu:
  "has_greatest_fixpoint f ⟹ apx.has_least_fixpoint f ⟹ κ f ⊑ ν f"
  by (metis apx.is_least_fixpoint_def apx.least_fixpoint nu_unfold)

end

class apx_semiring = apx_biorder + idempotent_left_semiring + L +
  assumes apx_L_least: "L ⊑ x"
  assumes sup_apx_left_isotone: "x ⊑ y ⟶ x ⊔ z ⊑ y ⊔ z"
  assumes mult_apx_left_isotone: "x ⊑ y ⟶ x * z ⊑ y * z"
  assumes mult_apx_right_isotone: "x ⊑ y ⟶ z * x ⊑ z * y"
begin

lemma sup_apx_right_isotone:
  "x ⊑ y ⟹ z ⊔ x ⊑ z ⊔ y"
  by (simp add: sup_apx_left_isotone sup_commute)

lemma sup_apx_isotone:
  "w ⊑ y ⟹ x ⊑ z ⟹ w ⊔ x ⊑ y ⊔ z"
  by (meson apx_transitive sup_apx_left_isotone sup_apx_right_isotone)

lemma mult_apx_isotone:
  "w ⊑ y ⟹ x ⊑ z ⟹ w * x ⊑ y * z"
  by (meson apx_transitive mult_apx_left_isotone mult_apx_right_isotone)

lemma affine_apx_isotone:
  "apx.isotone (λx . y * x ⊔ z)"
  by (simp add: apx.isotone_def mult_apx_right_isotone sup_apx_left_isotone)

end

end

Theory Recursion_Strict

(* Title:      Strict Recursion
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Strict Recursion›

theory Recursion_Strict

imports N_Semirings Approximation

begin

class semiring_apx = n_semiring + apx +
  assumes apx_def: "x ⊑ y ⟷ x ≤ y ⊔ n(x) * L ∧ y ≤ x ⊔ n(x) * top"
begin

lemma apx_n_order_reverse:
  "y ⊑ x ⟹ n(x) ≤ n(y)"
  by (metis apx_def le_iff_sup n_sup_left_absorb_mult n_dist_sup n_export)

lemma apx_n_order:
  "x ⊑ y ⟹ y ⊑ x ⟹ n(x) = n(y)"
  by (simp add: apx_n_order_reverse order.antisym)

lemma apx_transitive:
  assumes "x ⊑ y"
      and "y ⊑ z"
    shows "x ⊑ z"
proof -
  have "n(y) * L ≤ n(x) * L"
    by (simp add: apx_n_order_reverse assms(1) mult_left_isotone)
  hence 1: "x ≤ z ⊔ n(x) * L"
    by (smt assms sup_assoc sup_right_divisibility apx_def le_iff_sup)
  have "z ≤ x ⊔ n(x) * top ⊔ n(x ⊔ n(x) * top) * top"
    by (smt (verit) assms sup_left_isotone order_refl sup_assoc sup_mono apx_def mult_left_isotone n_isotone order_trans)
  also have "... = x ⊔ n(x) * top"
    by (simp add: n_dist_sup n_export n_sup_left_absorb_mult)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

text ‹Theorem 16.1›

subclass apx_biorder
  apply unfold_locales
  apply (simp add: apx_def)
  apply (smt (verit) order.antisym le_sup_iff apx_def eq_refl le_iff_sup n_galois apx_n_order)
  using apx_transitive by blast

lemma sup_apx_left_isotone:
  assumes "x ⊑ y"
    shows "x ⊔ z ⊑ y ⊔ z"
proof -
  have "x ≤ y ⊔ n(x) * L ∧ y ≤ x ⊔ n(x) * top"
    using assms apx_def by auto
  hence "z ⊔ x ≤ z ⊔ y ⊔ n(z ⊔ x) * L ∧ z ⊔ y ≤ z ⊔ x ⊔ n(z ⊔ x) * top"
    by (metis sup_assoc sup_right_isotone mult_right_sub_dist_sup_right n_dist_sup order_trans)
  thus ?thesis
    by (simp add: apx_def sup_commute)
qed

lemma mult_apx_left_isotone:
  assumes "x ⊑ y"
    shows "x * z ⊑ y * z"
proof -
  have "x ≤ y ⊔ n(x) * L"
    using assms apx_def by auto
  hence "x * z ≤ y * z ⊔ n(x) * L"
    by (smt (verit, ccfv_threshold) L_left_zero mult_left_isotone semiring.distrib_right mult_assoc)
  hence 1: "x * z ≤ y * z ⊔ n(x * z) * L"
    by (meson mult_left_isotone n_mult_left_upper_bound order_lesseq_imp sup_mono)
  have "y * z ≤ x * z ⊔ n(x) * top * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  hence "y * z ≤ x * z ⊔ n(x * z) * top"
    using mult_isotone n_mult_left_upper_bound order.trans sup_right_isotone top_greatest mult_assoc by presburger
  thus ?thesis
    using 1 by (simp add: apx_def)
qed

lemma mult_apx_right_isotone:
  assumes "x ⊑ y"
    shows "z * x ⊑ z * y"
proof -
  have "x ≤ y ⊔ n(x) * L"
    using assms apx_def by auto
  hence 1: "z * x ≤ z * y ⊔ n(z * x) * L"
    by (smt sup_assoc sup_ge1 sup_bot_right mult_assoc mult_left_dist_sup mult_right_isotone n_L_split)
  have "y ≤ x ⊔ n(x) * top"
    using assms apx_def by auto
  hence "z * y ≤ z * x ⊔ z * n(x) * top"
    by (smt mult_assoc mult_left_dist_sup mult_right_isotone)
  also have "... ≤ z * x ⊔ n(z * x) * top"
    by (smt (verit) sup_assoc le_supI le_sup_iff sup_ge1 sup_bot_right mult_left_dist_sup n_L_split n_top_split order_trans)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

text ‹Theorem 16.1 and Theorem 16.2›

subclass apx_semiring
  apply unfold_locales
  apply (metis sup_right_top sup_ge2 apx_def mult_left_one n_L top_greatest)
  apply (simp add: sup_apx_left_isotone)
  apply (simp add: mult_apx_left_isotone)
  by (simp add: mult_apx_right_isotone)

text ‹Theorem 16.2›

lemma ni_apx_isotone:
  "x ⊑ y ⟹ ni(x) ⊑ ni(y)"
  using apx_n_order_reverse apx_def le_supI1 n_ni ni_def ni_n_order by force

text ‹Theorem 17›

definition kappa_apx_meet :: "('a ⇒ 'a) ⇒ bool"
  where "kappa_apx_meet f ≡ apx.has_least_fixpoint f ∧ has_apx_meet (μ f) (ν f) ∧ κ f = μ f △ ν f"

definition kappa_mu_nu :: "('a ⇒ 'a) ⇒ bool"
  where "kappa_mu_nu f ≡ apx.has_least_fixpoint f ∧ κ f = μ f ⊔ n(ν f) * L"

definition nu_below_mu_nu :: "('a ⇒ 'a) ⇒ bool"
  where "nu_below_mu_nu f ≡ ν f ≤ μ f ⊔ n(ν f) * top"

definition mu_nu_apx_nu :: "('a ⇒ 'a) ⇒ bool"
  where "mu_nu_apx_nu f ≡ μ f ⊔ n(ν f) * L ⊑ ν f"

definition mu_nu_apx_meet :: "('a ⇒ 'a) ⇒ bool"
  where "mu_nu_apx_meet f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f = μ f ⊔ n(ν f) * L"

definition apx_meet_below_nu :: "('a ⇒ 'a) ⇒ bool"
  where "apx_meet_below_nu f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f ≤ ν f"

lemma mu_below_l:
  "μ f ≤ μ f ⊔ n(ν f) * L"
  by simp

lemma l_below_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ μ f ⊔ n(ν f) * L ≤ ν f"
  by (simp add: mu_below_nu n_L_decreasing)

lemma n_l_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ n(μ f ⊔ n(ν f) * L) = n(ν f)"
  by (metis le_iff_sup mu_below_nu n_dist_sup n_n_L)

lemma l_apx_mu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ μ f ⊔ n(ν f) * L ⊑ μ f"
  by (simp add: apx_def le_supI1 n_l_nu)

text ‹Theorem 17.4 implies Theorem 17.5›

lemma nu_below_mu_nu_mu_nu_apx_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ nu_below_mu_nu f ⟹ mu_nu_apx_nu f"
  by (smt (z3) l_below_nu apx_def le_sup_iff sup.absorb2 sup_commute sup_monoid.add_assoc mu_nu_apx_nu_def n_l_nu nu_below_mu_nu_def)

text ‹Theorem 17.5 implies Theorem 17.6›

lemma mu_nu_apx_nu_mu_nu_apx_meet:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "mu_nu_apx_nu f"
    shows "mu_nu_apx_meet f"
proof -
  let ?l = "μ f ⊔ n(ν f) * L"
  have "is_apx_meet (μ f) (ν f) ?l"
    apply (unfold is_apx_meet_def, intro conjI)
    apply (simp add: assms(1,2) l_apx_mu)
    using assms(3) mu_nu_apx_nu_def apply blast
    by (meson assms(1,2) l_below_nu apx_def order_trans sup_ge1 sup_left_isotone)
  thus ?thesis
    by (simp add: apx_meet_char mu_nu_apx_meet_def)
qed

text ‹Theorem 17.6 implies Theorem 17.7›

lemma mu_nu_apx_meet_apx_meet_below_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ mu_nu_apx_meet f ⟹ apx_meet_below_nu f"
  using apx_meet_below_nu_def l_below_nu mu_nu_apx_meet_def by auto

text ‹Theorem 17.7 implies Theorem 17.4›

lemma apx_meet_below_nu_nu_below_mu_nu:
  assumes "apx_meet_below_nu f"
    shows "nu_below_mu_nu f"
proof -
  have "∀m . m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f ⟶ ν f ≤ μ f ⊔ n(m) * top"
    by (smt (verit) sup_assoc sup_left_isotone sup_right_top apx_def mult_left_dist_sup order_trans)
  thus ?thesis
    by (smt (verit) assms sup_right_isotone apx_greatest_lower_bound apx_meet_below_nu_def apx_reflexive mult_left_isotone n_isotone nu_below_mu_nu_def order_trans)
qed

text ‹Theorem 17.1 implies Theorem 17.2›

lemma has_apx_least_fixpoint_kappa_apx_meet:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "apx.has_least_fixpoint f"
    shows "kappa_apx_meet f"
proof -
  have "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ w ⊑ κ f"
    by (meson assms apx_def order.trans kappa_below_nu mu_below_kappa semiring.add_right_mono)
  hence "is_apx_meet (μ f) (ν f) (κ f)"
    by (simp add: assms is_apx_meet_def kappa_apx_below_mu kappa_apx_below_nu)
  thus ?thesis
    by (simp add: assms(3) kappa_apx_meet_def apx_meet_char)
qed

text ‹Theorem 17.2 implies Theorem 17.7›

lemma kappa_apx_meet_apx_meet_below_nu:
  "has_greatest_fixpoint f ⟹ kappa_apx_meet f ⟹ apx_meet_below_nu f"
  using apx_meet_below_nu_def kappa_apx_meet_def kappa_below_nu by force

text ‹Theorem 17.7 implies Theorem 17.3›

lemma apx_meet_below_nu_kappa_mu_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "isotone f"
      and "apx.isotone f"
      and "apx_meet_below_nu f"
    shows "kappa_mu_nu f"
proof -
  let ?l = "μ f ⊔ n(ν f) * L"
  let ?m = "μ f △ ν f"
  have 1: "?l ⊑ ν f"
    using apx_meet_below_nu_nu_below_mu_nu assms(1,2,5) mu_nu_apx_nu_def nu_below_mu_nu_mu_nu_apx_nu by blast
  hence 2: "?m = ?l"
    using assms(1,2) mu_nu_apx_meet_def mu_nu_apx_nu_def mu_nu_apx_nu_mu_nu_apx_meet by blast
  have "μ f ≤ f(?l)"
    by (metis assms(1,3) isotone_def mu_unfold sup_ge1)
  hence 3: "?l ≤ f(?l) ⊔ n(?l) * L"
    using assms(1,2) semiring.add_right_mono n_l_nu by auto
  have "f(?l) ≤ f(ν f)"
    using assms(1-3) l_below_nu isotone_def by blast
  also have "... ≤ ?l ⊔ n(?l) * top"
    using 1 by (metis assms(2) apx_def nu_unfold)
  finally have 4: "?l ⊑ f(?l)"
    using 3 apx_def by blast
  have 5: "f(?l) ⊑ μ f"
    by (metis assms(1,2,4) apx.isotone_def is_least_fixpoint_def least_fixpoint l_apx_mu)
  have "f(?l) ⊑ ν f"
    using 1 by (metis assms(2,4) apx.isotone_def greatest_fixpoint is_greatest_fixpoint_def)
  hence "f(?l) ⊑ ?l"
    using 2 5 apx_meet_below_nu_def assms(5) apx_greatest_lower_bound by fastforce
  hence "f(?l) = ?l"
    using 4 by (simp add: apx.order.antisym)
  thus ?thesis
    using 1 by (smt (verit, del_insts) assms(1,2) sup_left_isotone apx_antisymmetric apx_def apx.least_fixpoint_char greatest_fixpoint apx.is_least_fixpoint_def is_greatest_fixpoint_def is_least_fixpoint_def least_fixpoint n_l_nu order_trans kappa_mu_nu_def)
qed

text ‹Theorem 17.3 implies Theorem 17.1›

lemma kappa_mu_nu_has_apx_least_fixpoint:
  "kappa_mu_nu f ⟹ apx.has_least_fixpoint f"
  using kappa_mu_nu_def by auto

text ‹Theorem 17.4 implies Theorem 17.3›

lemma nu_below_mu_nu_kappa_mu_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ isotone f ⟹ apx.isotone f ⟹ nu_below_mu_nu f ⟹ kappa_mu_nu f"
  using apx_meet_below_nu_kappa_mu_nu mu_nu_apx_meet_apx_meet_below_nu mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_mu_nu_apx_nu by blast

text ‹Theorem 17.3 implies Theorem 17.4›

lemma kappa_mu_nu_nu_below_mu_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ kappa_mu_nu f ⟹ nu_below_mu_nu f"
  by (simp add: apx_meet_below_nu_nu_below_mu_nu has_apx_least_fixpoint_kappa_apx_meet kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_def)

definition kappa_mu_nu_ni :: "('a ⇒ 'a) ⇒ bool"
  where "kappa_mu_nu_ni f ≡ apx.has_least_fixpoint f ∧ κ f = μ f ⊔ ni(ν f)"

lemma kappa_mu_nu_ni_kappa_mu_nu:
  "kappa_mu_nu_ni f ⟷ kappa_mu_nu f"
  by (simp add: kappa_mu_nu_def kappa_mu_nu_ni_def ni_def)

lemma nu_below_mu_nu_kappa_mu_nu_ni:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ isotone f ⟹ apx.isotone f ⟹ nu_below_mu_nu f ⟹ kappa_mu_nu_ni f"
  by (simp add: kappa_mu_nu_ni_kappa_mu_nu nu_below_mu_nu_kappa_mu_nu)

lemma kappa_mu_nu_ni_nu_below_mu_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ kappa_mu_nu_ni f ⟹ nu_below_mu_nu f"
  using kappa_mu_nu_ni_kappa_mu_nu kappa_mu_nu_nu_below_mu_nu by blast

end

class itering_apx = n_itering + semiring_apx
begin

text ‹Theorem 16.3›

lemma circ_apx_isotone:
  assumes "x ⊑ y"
    shows "x⇧^∘ ⊑ y⇧^∘"
proof -
  have 1: "x ≤ y ⊔ n(x) * L ∧ y ≤ x ⊔ n(x) * top"
    using assms apx_def by auto
  hence "y⇧^∘ ≤ x⇧^∘ ⊔ x⇧^∘ * n(x) * top"
    by (metis circ_isotone circ_left_top circ_unfold_sum mult_assoc)
  also have "... ≤ x⇧^∘ ⊔ n(x⇧^∘ * x) * top"
    by (smt le_sup_iff n_isotone n_top_split order_refl order_trans right_plus_below_circ zero_right_mult_decreasing)
  also have "... ≤ x⇧^∘ ⊔ n(x⇧^∘) * top"
    by (simp add: circ_plus_same n_circ_left_unfold)
  finally have 2: "y⇧^∘ ≤ x⇧^∘ ⊔ n(x⇧^∘) * top"
    .
  have "x⇧^∘ ≤ y⇧^∘ ⊔ y⇧^∘ * n(x) * L"
    using 1 by (metis L_left_zero circ_isotone circ_unfold_sum mult_assoc)
  also have "... = y⇧^∘ ⊔ n(y⇧^∘ * x) * L"
    by (metis sup_assoc sup_bot_right mult_assoc mult_zero_sup_circ_2 n_L_split n_mult_right_bot)
  also have "... ≤ y⇧^∘ ⊔ n(x⇧^∘ * x) * L ⊔ n(x⇧^∘) * n(top * x) * L"
    using 2 by (metis sup_assoc sup_right_isotone mult_assoc mult_left_isotone mult_right_dist_sup n_dist_sup n_export n_isotone)
  finally have "x⇧^∘ ≤ y⇧^∘ ⊔ n(x⇧^∘) * L"
    by (metis sup_assoc circ_plus_same n_sup_left_absorb_mult n_circ_left_unfold n_dist_sup n_export ni_def ni_dist_sup)
  thus ?thesis
    using 2 by (simp add: apx_def)
qed

end

class omega_algebra_apx = n_omega_algebra_2 + semiring_apx

sublocale omega_algebra_apx < star: itering_apx where circ = star ..

sublocale omega_algebra_apx < nL_omega: itering_apx where circ = Omega ..

context omega_algebra_apx
begin

text ‹Theorem 16.4›

lemma omega_apx_isotone:
  assumes "x ⊑ y"
    shows "x⇧^ω ⊑ y⇧^ω"
proof -
  have 1: "x ≤ y ⊔ n(x) * L ∧ y ≤ x ⊔ n(x) * top"
    using assms apx_def by auto
  hence "y⇧^ω ≤ x⇧^⋆ * n(x) * top * (x⇧^⋆ * n(x) * top)⇧^ω ⊔ x⇧^ω ⊔ x⇧^⋆ * n(x) * top * (x⇧^⋆ * n(x) * top)⇧^⋆ * x⇧^ω"
    by (smt sup_assoc mult_assoc mult_left_one mult_right_dist_sup omega_decompose omega_isotone omega_unfold star_left_unfold_equal)
  also have "... ≤ x⇧^⋆ * n(x) * top ⊔ x⇧^ω ⊔ x⇧^⋆ * n(x) * top * (x⇧^⋆ * n(x) * top)⇧^⋆ * x⇧^ω"
    using mult_top_omega omega_unfold sup_left_isotone by auto
  also have "... = x⇧^⋆ * n(x) * top ⊔ x⇧^ω"
    by (smt (z3) mult_left_dist_sup sup_assoc sup_commute sup_left_top mult_assoc)
  also have "... ≤ n(x⇧^⋆ * x) * top ⊔ x⇧^⋆ * bot ⊔ x⇧^ω"
    using n_top_split semiring.add_left_mono sup_commute by fastforce
  also have "... ≤ n(x⇧^⋆ * x) * top ⊔ x⇧^ω"
    using semiring.add_right_mono star_bot_below_omega sup_commute by fastforce
  finally have 2: "y⇧^ω ≤ x⇧^ω ⊔ n(x⇧^ω) * top"
    by (metis sup_commute sup_right_isotone mult_left_isotone n_star_below_n_omega n_star_left_unfold order_trans star.circ_plus_same)
  have "x⇧^ω ≤ (y ⊔ n(x) * L)⇧^ω"
    using 1 by (simp add: omega_isotone)
  also have "... = y⇧^⋆ * n(x) * L * (y⇧^⋆ * n(x) * L)⇧^ω ⊔ y⇧^ω ⊔ y⇧^⋆ * n(x) * L * (y⇧^⋆ * n(x) * L)⇧^⋆ * y⇧^ω"
    by (smt sup_assoc mult_assoc mult_left_one mult_right_dist_sup omega_decompose omega_isotone omega_unfold star_left_unfold_equal)
  also have "... = y⇧^⋆ * n(x) * L ⊔ y⇧^ω"
    using L_left_zero sup_assoc sup_monoid.add_commute mult_assoc by force
  also have "... ≤ y⇧^ω ⊔ y⇧^⋆ * bot ⊔ n(y⇧^⋆ * x) * L"
    by (simp add: n_L_split sup_assoc sup_commute)
  also have "... ≤ y⇧^ω ⊔ n(x⇧^⋆ * x) * L ⊔ n(x⇧^⋆) * n(top * x) * L"
    using 1 by (metis sup_right_isotone sup_bot_right apx_def mult_assoc mult_left_dist_sup mult_left_isotone mult_right_dist_sup n_dist_sup n_export n_isotone star.circ_apx_isotone star_mult_omega sup_assoc)
  finally have "x⇧^ω ≤ y⇧^ω ⊔ n(x⇧^ω) * L"
    by (smt (verit, best) le_supE sup.orderE sup_commute sup_assoc sup_isotone mult_right_dist_sup n_sup_left_absorb_mult n_star_left_unfold ni_def ni_star_below_ni_omega order_refl order_trans star.circ_plus_same)
  thus ?thesis
    using 2 by (simp add: apx_def)
qed

end

class omega_algebra_apx_extra = omega_algebra_apx +
  assumes n_split_omega: "x⇧^ω ≤ x⇧^⋆ * bot ⊔ n(x⇧^ω) * top"
begin

lemma omega_n_star:
  "x⇧^ω ⊔ n(x⇧^⋆) * top ≤ x⇧^⋆ * n(x⇧^ω) * top"
proof -
  have 1: "n(x⇧^⋆) * top ≤ n(x⇧^ω) * top"
    by (simp add: mult_left_isotone n_star_below_n_omega)
  have "... ≤ x⇧^⋆ * n(x⇧^ω) * top"
    by (simp add: star_n_omega_top)
  thus ?thesis
    using 1 by (metis le_sup_iff n_split_omega order_trans star_n_omega_top)
qed

lemma n_omega_zero:
  "n(x⇧^ω) = bot ⟷ n(x⇧^⋆) = bot ∧ x⇧^ω ≤ x⇧^⋆ * bot"
  by (metis sup_bot_right order.eq_iff mult_left_zero n_mult_bot n_split_omega star_bot_below_omega)

lemma n_split_nu_mu:
  "y⇧^ω ⊔ y⇧^⋆ * z ≤ y⇧^⋆ * z ⊔ n(y⇧^ω ⊔ y⇧^⋆ * z) * top"
proof -
  have "y⇧^ω ≤ y⇧^⋆ * bot ⊔ n(y⇧^ω ⊔ y⇧^⋆ * z) * top"
    by (smt sup_ge1 sup_right_isotone mult_left_isotone n_isotone n_split_omega order_trans)
  also have "... ≤ y⇧^⋆ * z ⊔ n(y⇧^ω ⊔ y⇧^⋆ * z) * top"
    using nL_star.star_zero_below_circ_mult sup_left_isotone by auto
  finally show ?thesis
    by simp
qed

lemma loop_exists:
  "ν (λx . y * x ⊔ z) ≤ μ (λx . y * x ⊔ z) ⊔ n(ν (λx . y * x ⊔ z)) * top"
  by (metis n_split_nu_mu omega_loop_nu star_loop_mu)

lemma loop_apx_least_fixpoint:
  "apx.is_least_fixpoint (λx . y * x ⊔ z) (μ (λx . y * x ⊔ z) ⊔ n(ν (λx . y * x ⊔ z)) * L)"
  using apx.least_fixpoint_char affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone kappa_mu_nu_def nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu loop_exists by auto

lemma loop_has_apx_least_fixpoint:
  "apx.has_least_fixpoint (λx . y * x ⊔ z)"
  using affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone kappa_mu_nu_def nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu loop_exists by auto

lemma loop_semantics:
  "κ (λx . y * x ⊔ z) = μ (λx . y * x ⊔ z) ⊔ n(ν (λx . y * x ⊔ z)) * L"
  using apx.least_fixpoint_char loop_apx_least_fixpoint by auto

lemma loop_apx_least_fixpoint_ni:
  "apx.is_least_fixpoint (λx . y * x ⊔ z) (μ (λx . y * x ⊔ z) ⊔ ni(ν (λx . y * x ⊔ z)))"
  using ni_def loop_apx_least_fixpoint by auto

lemma loop_semantics_ni:
  "κ (λx . y * x ⊔ z) = μ (λx . y * x ⊔ z) ⊔ ni(ν (λx . y * x ⊔ z))"
  using ni_def loop_semantics by auto

text ‹Theorem 18›

lemma loop_semantics_kappa_mu_nu:
  "κ (λx . y * x ⊔ z) = n(y⇧^ω) * L ⊔ y⇧^⋆ * z"
proof -
  have "κ (λx . y * x ⊔ z) = y⇧^⋆ * z ⊔ n(y⇧^ω ⊔ y⇧^⋆ * z) * L"
    by (metis loop_semantics omega_loop_nu star_loop_mu)
  thus ?thesis
    by (smt sup_assoc sup_commute le_iff_sup mult_right_dist_sup n_L_decreasing n_dist_sup)
qed

end

class omega_algebra_apx_extra_2 = omega_algebra_apx +
  assumes omega_n_star: "x⇧^ω ≤ x⇧^⋆ * n(x⇧^ω) * top"
begin

subclass omega_algebra_apx_extra
  apply unfold_locales
  using omega_n_star star_n_omega_top by auto

end

end

Theory N_Algebras

(* Title:      N-Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹N-Algebras›

theory N_Algebras

imports Stone_Kleene_Relation_Algebras.Iterings Base Lattice_Ordered_Semirings

begin

class C_left_n_algebra = bounded_idempotent_left_semiring + bounded_distrib_lattice + n + L
begin

abbreviation C :: "'a ⇒ 'a" where "C x ≡ n(L) * top ⊓ x"

text ‹AACP Theorem 3.38›

lemma C_isotone:
  "x ≤ y ⟶ C x ≤ C y"
  using inf.sup_right_isotone by auto

text ‹AACP Theorem 3.40›

lemma C_decreasing:
  "C x ≤ x"
  by simp

end

class left_n_algebra = C_left_n_algebra +
  assumes n_dist_n_add            : "n(x) ⊔ n(y) = n(n(x) * top ⊔ y)"
  assumes n_export                : "n(x) * n(y) = n(n(x) * y)"
  assumes n_left_upper_bound      : "n(x) ≤ n(x ⊔ y)"
  assumes n_nL_meet_L_nL0         : "n(L) * x = (x ⊓ L) ⊔ n(L * bot) * x"
  assumes n_n_L_split_n_n_L_L     : "x * n(y) * L = x * bot ⊔ n(x * n(y) * L) * L"
  assumes n_sub_nL                : "n(x) ≤ n(L)"
  assumes n_L_decreasing          : "n(x) * L ≤ x"
  assumes n_L_T_meet_mult_combined: "C (x * y) * z ≤ C x * y * C z"
  assumes n_n_top_split_n_top     : "x * n(y) * top ≤ x * bot ⊔ n(x * y) * top"
  assumes n_top_meet_L_below_L    : "x * top * y ⊓ L ≤ x * L * y"
begin

subclass lattice_ordered_pre_left_semiring ..

lemma n_L_T_meet_mult_below:
  "C (x * y) ≤ C x * y"
proof -
  have "C (x * y) ≤ C x * y * C 1"
    by (meson order.trans mult_sub_right_one n_L_T_meet_mult_combined)
  also have "... ≤ C x * y"
    by (metis mult_1_right mult_left_sub_dist_inf_right)
  finally show ?thesis
    .
qed

text ‹AACP Theorem 3.41›

lemma n_L_T_meet_mult_propagate:
  "C x * y ≤ x * C y"
proof -
  have "C x * y ≤ C x * 1 * C y"
    by (metis mult_1_right mult_assoc n_L_T_meet_mult_combined mult_1_right)
  also have "... ≤ x * C y"
    by (simp add: mult_right_sub_dist_inf_right)
  finally show ?thesis
    .
qed

text ‹AACP Theorem 3.43›

lemma C_n_mult_closed:
  "C (n(x) * y) = n(x) * y"
  by (simp add: inf.absorb2 mult_isotone n_sub_nL)

text ‹AACP Theorem 3.40›

lemma meet_L_below_C:
  "x ⊓ L ≤ C x"
  by (simp add: le_supI1 n_nL_meet_L_nL0)

text ‹AACP Theorem 3.42›

lemma n_L_T_meet_mult:
  "C (x * y) = C x * y"
  apply (rule order.antisym)
  apply (rule n_L_T_meet_mult_below)
  by (smt (z3) C_n_mult_closed inf.boundedE inf.sup_monoid.add_assoc inf.sup_monoid.add_commute mult_right_sub_dist_inf mult_assoc)

text ‹AACP Theorem 3.42›

lemma C_mult_propagate:
  "C x * y = C x * C y"
  by (smt (z3) C_n_mult_closed order.eq_iff inf.left_commute inf.sup_monoid.add_commute mult_left_sub_dist_inf_right n_L_T_meet_mult_propagate)

text ‹AACP Theorem 3.32›

lemma meet_L_below_n_L:
  "x ⊓ L ≤ n(L) * x"
  by (simp add: n_nL_meet_L_nL0)

text ‹AACP Theorem 3.27›

lemma n_vector_meet_L:
  "x * top ⊓ L ≤ x * L"
  by (metis mult_1_right n_top_meet_L_below_L)

lemma n_right_upper_bound:
  "n(x) ≤ n(y ⊔ x)"
  by (simp add: n_left_upper_bound sup_commute)

text ‹AACP Theorem 3.1›

lemma n_isotone:
  "x ≤ y ⟹ n(x) ≤ n(y)"
  by (metis le_iff_sup n_left_upper_bound)

lemma n_add_left_zero:
  "n(bot) ⊔ n(x) = n(x)"
  using le_iff_sup sup_bot_right sup_right_divisibility n_isotone by auto

text ‹AACP Theorem 3.13›

lemma n_mult_right_zero_L:
  "n(x) * bot ≤ L"
  by (meson bot_least mult_isotone n_L_decreasing n_sub_nL order_trans)

lemma n_add_left_top:
  "n(top) ⊔ n(x) = n(top)"
  by (simp add: sup_absorb1 n_isotone)

text ‹AACP Theorem 3.18›

lemma n_n_L:
  "n(n(x) * L) = n(x)"
  by (metis order.antisym n_dist_n_add n_export n_sub_nL sup_bot_right sup_commute sup_top_left n_add_left_zero n_right_upper_bound)

lemma n_mult_transitive:
  "n(x) * n(x) ≤ n(x)"
  by (metis mult_right_isotone n_export n_sub_nL n_n_L)

lemma n_mult_left_absorb_add_sub:
  "n(x) * (n(x) ⊔ n(y)) ≤ n(x)"
  by (metis mult_right_isotone n_dist_n_add n_export n_sub_nL n_n_L)

text ‹AACP Theorem 3.21›

lemma n_mult_left_lower_bound:
  "n(x) * n(y) ≤ n(x)"
  by (metis mult_right_isotone n_export n_sub_nL n_n_L)

text ‹AACP Theorem 3.20›

lemma n_mult_left_zero:
  "n(bot) * n(x) = n(bot)"
  by (metis n_export sup_absorb1 n_add_left_zero n_mult_left_lower_bound)

lemma n_mult_right_one:
  "n(x) * n(top) = n(x)"
  using n_dist_n_add n_export sup_commute n_add_left_zero by fastforce

lemma n_L_increasing:
  "n(x) ≤ n(n(x) * L)"
  by (simp add: n_n_L)

text ‹AACP Theorem 3.2›

lemma n_galois:
  "n(x) ≤ n(y) ⟷ n(x) * L ≤ y"
  by (metis mult_left_isotone n_L_decreasing n_L_increasing n_isotone order_trans)

lemma n_add_n_top:
  "n(x ⊔ n(x) * top) = n(x)"
  by (metis n_dist_n_add sup.idem sup_commute)

text ‹AACP Theorem 3.6›

lemma n_L_below_nL_top:
  "L ≤ n(L) * top"
  by (metis inf_top.left_neutral meet_L_below_n_L)

text ‹AACP Theorem 3.4›

lemma n_less_eq_char_n:
  "x ≤ y ⟷ x ≤ y ⊔ L ∧ C x ≤ y ⊔ n(y) * top"
proof
  assume "x ≤ y"
  thus "x ≤ y ⊔ L ∧ C x ≤ y ⊔ n(y) * top"
    by (simp add: inf.coboundedI2 le_supI1)
next
  assume 1: "x ≤ y ⊔ L ∧ C x ≤ y ⊔ n(y) * top"
  hence "x ≤ y ⊔ (x ⊓ L)"
    using sup_commute sup_inf_distrib2 by force
  also have "... ≤ y ⊔ C x"
    using sup_right_isotone meet_L_below_C by blast
  also have "... ≤ y ⊔ n(y) * top"
    using 1 by simp
  finally have "x ≤ y ⊔ (L ⊓ n(y) * top)"
    using 1 by (simp add: sup_inf_distrib1)
  thus "x ≤ y"
    by (metis inf_commute n_L_decreasing order_trans sup_absorb1 n_vector_meet_L)
qed

text ‹AACP Theorem 3.31›

lemma n_L_decreasing_meet_L:
  "n(x) * L ≤ x ⊓ L"
  using n_sub_nL n_galois by auto

text ‹AACP Theorem 3.5›

lemma n_zero_L_zero:
  "n(bot) * L = bot"
  by (simp add: le_bot n_L_decreasing)

lemma n_L_top_below_L:
  "L * top ≤ L"
proof -
  have "n(L * bot) * L * top ≤ L * bot"
    by (metis dense_top_closed mult_isotone n_L_decreasing zero_vector mult_assoc)
  hence "n(L * bot) * L * top ≤ L"
    using order_lesseq_imp zero_right_mult_decreasing by blast
  hence "n(L) * L * top ≤ L"
    by (metis inf.absorb2 n_nL_meet_L_nL0 order.refl sup.absorb_iff1 top_right_mult_increasing mult_assoc)
  thus "L * top ≤ L"
    by (metis inf.absorb2 inf.sup_monoid.add_commute n_L_decreasing n_L_below_nL_top n_vector_meet_L)
qed

text ‹AACP Theorem 3.9›

lemma n_L_top_L:
  "L * top = L"
  by (simp add: order.antisym top_right_mult_increasing n_L_top_below_L)

text ‹AACP Theorem 3.10›

lemma n_L_below_L:
  "L * x ≤ L"
  by (metis mult_right_isotone top.extremum n_L_top_L)

text ‹AACP Theorem 3.7›

lemma n_nL_nT:
  "n(L) = n(top)"
  using order.eq_iff n_sub_nL n_add_left_top by auto

text ‹AACP Theorem 3.8›

lemma n_L_L:
  "n(L) * L = L"
  using order.antisym meet_L_below_n_L n_L_decreasing_meet_L by fastforce

lemma n_top_L:
  "n(top) * L = L"
  using n_L_L n_nL_nT by auto

text ‹AACP Theorem 3.23›

lemma n_n_L_split_n_L:
  "x * n(y) * L ≤ x * bot ⊔ n(x * y) * L"
  by (metis n_n_L_split_n_n_L_L n_L_decreasing mult_assoc mult_left_isotone mult_right_isotone n_isotone sup_right_isotone)

text ‹AACP Theorem 3.12›

lemma n_L_split_n_L_L:
  "x * L = x * bot ⊔ n(x * L) * L"
  apply (rule order.antisym)
  apply (metis mult_assoc n_n_L_split_n_L n_L_L)
  by (simp add: mult_right_isotone n_L_decreasing)

text ‹AACP Theorem 3.11›

lemma n_L_split_L:
  "x * L ≤ x * bot ⊔ L"
  by (metis n_n_L_split_n_n_L_L n_sub_nL sup_right_isotone mult_assoc n_L_L n_galois)

text ‹AACP Theorem 3.24›

lemma n_split_top:
  "x * n(y) * top ≤ x * y ⊔ n(x * y) * top"
proof -
  have "x * bot ⊔ n(x * y) * top ≤ x * y ⊔ n(x * y) * top"
    by (meson bot_least mult_isotone order.refl sup_left_isotone)
  thus ?thesis
    using order.trans n_n_top_split_n_top by blast
qed

text ‹AACP Theorem 3.9›

lemma n_L_L_L:
  "L * L = L"
  by (metis inf.sup_monoid.add_commute inf_absorb1 n_L_below_L n_L_top_L n_vector_meet_L)

text ‹AACP Theorem 3.9›

lemma n_L_top_L_L:
  "L * top * L = L"
  by (simp add: n_L_L_L n_L_top_L)

text ‹AACP Theorem 3.19›

lemma n_n_nL:
  "n(x) = n(x) * n(L)"
  by (simp add: n_export n_n_L)

lemma n_L_mult_idempotent:
  "n(L) * n(L) = n(L)"
  using n_n_nL by auto

text ‹AACP Theorem 3.22›

lemma n_n_L_n:
  "n(x * n(y) * L) ≤ n(x * y)"
  by (simp add: mult_right_isotone n_L_decreasing mult_assoc n_isotone)

text ‹AACP Theorem 3.3›

lemma n_less_eq_char:
  "x ≤ y ⟷ x ≤ y ⊔ L ∧ x ≤ y ⊔ n(y) * top"
  by (meson inf.coboundedI2 le_supI1 n_less_eq_char_n)

text ‹AACP Theorem 3.28›

lemma n_top_meet_L_split_L:
  "x * top * y ⊓ L ≤ x * bot ⊔ L * y"
proof -
  have "x * top * y ⊓ L ≤ x * bot ⊔ n(x * L) * L * y"
    by (smt n_top_meet_L_below_L mult_assoc n_L_L_L n_L_split_n_L_L mult_right_dist_sup mult_left_zero)
  also have "... ≤ x * bot ⊔ x * L * y"
    using mult_left_isotone n_L_decreasing sup_right_isotone by force
  also have "... ≤ x * bot ⊔ (x * bot ⊔ L) * y"
    using mult_left_isotone sup_right_isotone n_L_split_L by blast
  also have "... = x * bot ⊔ x * bot * y ⊔ L * y"
    by (simp add: mult_right_dist_sup sup_assoc)
  also have "... = x * bot ⊔ L * y"
    by (simp add: mult_assoc)
  finally show ?thesis
    .
qed

text ‹AACP Theorem 3.29›

lemma n_top_meet_L_L_meet_L:
  "x * top * y ⊓ L = x * L * y ⊓ L"
  apply (rule order.antisym)
  apply (simp add: n_top_meet_L_below_L)
  by (metis inf.sup_monoid.add_commute inf.sup_right_isotone mult_isotone order.refl top.extremum)

lemma n_n_top_below_n_L:
  "n(x * top) ≤ n(x * L)"
  by (meson order.trans n_L_decreasing_meet_L n_galois n_vector_meet_L)

text ‹AACP Theorem 3.14›

lemma n_n_top_n_L:
  "n(x * top) = n(x * L)"
  by (metis order.antisym mult_right_isotone n_isotone n_n_top_below_n_L top_greatest)

text ‹AACP Theorem 3.30›

lemma n_meet_L_0_below_0_meet_L:
  "(x ⊓ L) * bot ≤ x * bot ⊓ L"
  by (meson inf.boundedE inf.boundedI mult_right_sub_dist_inf_left zero_right_mult_decreasing)

text ‹AACP Theorem 3.15›

lemma n_n_L_below_L:
  "n(x) * L ≤ x * L"
  by (metis mult_assoc mult_left_isotone n_L_L_L n_L_decreasing)

lemma n_n_L_below_n_L_L:
  "n(x) * L ≤ n(x * L) * L"
  by (simp add: mult_left_isotone n_galois n_n_L_below_L)

text ‹AACP Theorem 3.16›

lemma n_below_n_L:
  "n(x) ≤ n(x * L)"
  by (simp add: n_galois n_n_L_below_L)

text ‹AACP Theorem 3.17›

lemma n_below_n_L_mult:
  "n(x) ≤ n(L) * n(x)"
  by (metis n_export order_trans meet_L_below_n_L n_L_decreasing_meet_L n_isotone n_n_L)

text ‹AACP Theorem 3.33›

lemma n_meet_L_below:
  "n(x) ⊓ L ≤ x"
  by (meson inf.coboundedI1 inf.coboundedI2 le_supI2 sup.cobounded1 top_right_mult_increasing n_less_eq_char)

text ‹AACP Theorem 3.35›

lemma n_meet_L_top_below_n_L:
  "(n(x) ⊓ L) * top ≤ n(x) * L"
proof -
  have "(n(x) ⊓ L) * top ≤ n(x) * top ⊓ L * top"
    by (meson mult_right_sub_dist_inf)
  thus ?thesis
    by (metis n_L_top_L n_vector_meet_L order_trans)
qed

text ‹AACP Theorem 3.34›

lemma n_meet_L_top_below:
  "(n(x) ⊓ L) * top ≤ x"
  using order.trans n_L_decreasing n_meet_L_top_below_n_L by blast

text ‹AACP Theorem 3.36›

lemma n_n_meet_L:
  "n(x) = n(x ⊓ L)"
  by (meson order.antisym inf.cobounded1 n_L_decreasing_meet_L n_galois n_isotone)

lemma n_T_below_n_meet:
  "n(x) * top = n(C x) * top"
  by (metis inf.absorb2 inf.sup_monoid.add_assoc meet_L_below_C n_n_meet_L)

text ‹AACP Theorem 3.44›

lemma n_C:
  "n(C x) = n(x)"
  by (metis n_T_below_n_meet n_export n_mult_right_one)

text ‹AACP Theorem 3.37›

lemma n_T_meet_L:
  "n(x) * top ⊓ L = n(x) * L"
  by (metis antisym_conv n_L_decreasing_meet_L n_n_L n_n_top_n_L n_vector_meet_L)

text ‹AACP Theorem 3.39›

lemma n_L_top_meet_L:
  "C L = L"
  by (simp add: n_L_L n_T_meet_L)

end

class n_algebra = left_n_algebra + idempotent_left_zero_semiring
begin

(* independence of axioms, checked in n_algebra without the respective axiom:
  lemma n_dist_n_add            : "n(x) ⊔ n(y) = n(n(x) * top ⊔ y)" nitpick [expect=genuine,card=5] oops
  lemma n_export                : "n(x) * n(y) = n(n(x) * y)" nitpick [expect=genuine,card=4] oops
  lemma n_left_upper_bound      : "n(x) ≤ n(x ⊔ y)" nitpick [expect=genuine,card=5] oops
  lemma n_nL_meet_L_nL0         : "n(L) * x = (x ⊓ L) ⊔ n(L * bot) * x" nitpick [expect=genuine,card=2] oops
  lemma n_n_L_split_n_n_L_L     : "x * n(y) * L = x * bot ⊔ n(x * n(y) * L) * L" nitpick [expect=genuine,card=6] oops
  lemma n_sub_nL                : "n(x) ≤ n(L)" nitpick [expect=genuine,card=2] oops
  lemma n_L_decreasing          : "n(x) * L ≤ x" nitpick [expect=genuine,card=3] oops
  lemma n_L_T_meet_mult_combined: "C (x * y) * z ≤ C x * y * C z" nitpick [expect=genuine,card=4] oops
  lemma n_n_top_split_n_top     : "x * n(y) * top ≤ x * bot ⊔ n(x * y) * top" nitpick [expect=genuine,card=4] oops
  lemma n_top_meet_L_below_L    : "x * top * y ⊓ L ≤ x * L * y" nitpick [expect=genuine,card=5] oops
*)

text ‹AACP Theorem 3.25›

lemma n_top_split_0:
  "n(x) * top * y ≤ x * y ⊔ n(x * bot) * top"
proof -
  have 1: "n(x) * top * y ⊓ L ≤ x * y"
    using inf.coboundedI1 mult_left_isotone n_L_decreasing_meet_L n_top_meet_L_L_meet_L by force
  have "n(x) * top * y = n(x) * n(L) * top * y"
    using n_n_nL by auto
  also have "... = n(x) * ((top * y ⊓ L) ⊔ n(L * bot) * top * y)"
    by (metis mult_assoc n_nL_meet_L_nL0)
  also have "... ≤ n(x) * (top * y ⊓ L) ⊔ n(x) * n(L * bot) * top"
    by (metis sup_right_isotone mult_assoc mult_left_dist_sup mult_right_isotone top_greatest)
  also have "... ≤ (n(x) * top * y ⊓ L) ⊔ n(n(x) * L * bot) * top"
    by (smt sup_left_isotone order.trans inf_greatest mult_assoc mult_left_sub_dist_inf_left mult_left_sub_dist_inf_right n_export n_galois n_sub_nL)
  also have "... ≤ x * y ⊔ n(n(x) * L * bot) * top"
    using 1 sup_left_isotone by blast
  also have "... ≤ x * y ⊔ n(x * bot) * top"
    using mult_left_isotone n_galois n_isotone order.refl sup_right_isotone by auto
  finally show ?thesis
    .
qed

text ‹AACP Theorem 3.26›

lemma n_top_split:
  "n(x) * top * y ≤ x * y ⊔ n(x * y) * top"
  by (metis order.trans sup_bot_right mult_assoc sup_right_isotone mult_left_isotone mult_left_sub_dist_sup_right n_isotone n_top_split_0)

(*
lemma n_zero: "n(bot) = bot" nitpick [expect=genuine,card=2] oops
lemma n_one: "n(1) = bot" nitpick [expect=genuine,card=2] oops
lemma n_nL_one: "n(L) = 1" nitpick [expect=genuine,card=2] oops
lemma n_nT_one: "n(top) = 1" nitpick [expect=genuine,card=2] oops
lemma n_n_zero: "n(x) = n(x * bot)" nitpick [expect=genuine,card=2] oops
lemma n_dist_add: "n(x) ⊔ n(y) = n(x ⊔ y)" nitpick [expect=genuine,card=4] oops
lemma n_L_split: "x * n(y) * L = x * bot ⊔ n(x * y) * L" nitpick [expect=genuine,card=3] oops
lemma n_split: "x ≤ x * bot ⊔ n(x * L) * top" nitpick [expect=genuine,card=2] oops
lemma n_mult_top_1: "n(x * y) ≤ n(x * n(y) * top)" nitpick [expect=genuine,card=3] oops
lemma l91_1: "n(L) * x ≤ n(x * top) * top" nitpick [expect=genuine,card=3] oops
lemma meet_domain_top: "x ⊓ n(y) * top = n(y) * x" nitpick [expect=genuine,card=3] oops
lemma meet_domain_2: "x ⊓ n(y) * top ≤ n(L) * x" nitpick [expect=genuine,card=4] oops
lemma n_nL_top_n_top_meet_L_top_2: "n(L) * x * top ≤ n(x * top ⊓ L) * top" nitpick [expect=genuine,card=3] oops
lemma n_nL_top_n_top_meet_L_top_1: "n(x * top ⊓ L) * top ≤ n(L) * x * top" nitpick [expect=genuine,card=2] oops
lemma l9: "x * bot ⊓ L ≤ n(x * L) * L" nitpick [expect=genuine,card=4] oops
lemma l18_2: "n(x * L) * L ≤ n(x) * L" nitpick [expect=genuine,card=3] oops
lemma l51_1: "n(x) * L ≤ (x ⊓ L) * bot" nitpick [expect=genuine,card=2] oops
lemma l51_2: "(x ⊓ L) * bot ≤ n(x) * L" nitpick [expect=genuine,card=4] oops

lemma n_split_equal: "x ⊔ n(x * L) * top = x * bot ⊔ n(x * L) * top" nitpick [expect=genuine,card=2] oops
lemma n_split_top: "x * top ≤ x * bot ⊔ n(x * L) * top" nitpick [expect=genuine,card=2] oops
lemma n_mult: "n(x * n(y) * L) = n(x * y)" nitpick [expect=genuine,card=3] oops
lemma n_mult_1: "n(x * y) ≤ n(x * n(y) * L)" nitpick [expect=genuine,card=3] oops
lemma n_mult_top: "n(x * n(y) * top) = n(x * y)" nitpick [expect=genuine,card=3] oops
lemma n_mult_right_upper_bound: "n(x * y) ≤ n(z) ⟷ n(x) ≤ n(z) ∧ x * n(y) * L ≤ x * bot ⊔ n(z) * L" nitpick [expect=genuine,card=2] oops
lemma meet_domain: "x ⊓ n(y) * z = n(y) * (x ⊓ z)" nitpick [expect=genuine,card=3] oops
lemma meet_domain_1: "x ⊓ n(y) * z ≤ n(y) * x" nitpick [expect=genuine,card=3] oops
lemma meet_domain_top_3: "x ⊓ n(y) * top ≤ n(y) * x" nitpick [expect=genuine,card=3] oops
lemma n_n_top_n_top_split_n_n_top_top: "n(x) * top ⊔ x * n(y) * top = x * bot ⊔ n(x * n(y) * top) * top" nitpick [expect=genuine,card=2] oops
lemma n_n_top_n_top_split_n_n_top_top_1: "x * bot ⊔ n(x * n(y) * top) * top ≤ n(x) * top ⊔ x * n(y) * top" nitpick [expect=genuine,card=5] oops
lemma n_n_top_n_top_split_n_n_top_top_2: "n(x) * top ⊔ x * n(y) * top ≤ x * bot ⊔ n(x * n(y) * top) * top" nitpick [expect=genuine,card=2] oops
lemma n_nL_top_n_top_meet_L_top: "n(L) * x * top = n(x * top ⊓ L) * top" nitpick [expect=genuine,card=2] oops
lemma l18: "n(x) * L = n(x * L) * L" nitpick [expect=genuine,card=3] oops
lemma l22: "x * bot ⊓ L = n(x) * L" nitpick [expect=genuine,card=2] oops
lemma l22_1: "x * bot ⊓ L = n(x * L) * L" nitpick [expect=genuine,card=2] oops
lemma l22_2: "x ⊓ L = n(x) * L" nitpick [expect=genuine,card=3] oops
lemma l22_3: "x ⊓ L = n(x * L) * L" nitpick [expect=genuine,card=3] oops
lemma l22_4: "x ⊓ L ≤ n(x) * L" nitpick [expect=genuine,card=3] oops
lemma l22_5: "x * bot ⊓ L ≤ n(x) * L" nitpick [expect=genuine,card=4] oops
lemma l23: "x * top ⊓ L = n(x) * L" nitpick [expect=genuine,card=3] oops
lemma l51: "n(x) * L = (x ⊓ L) * bot" nitpick [expect=genuine,card=2] oops
lemma l91: "x = x * top ⟶ n(L) * x ≤ n(x) * top" nitpick [expect=genuine,card=3] oops
lemma l92: "x = x * top ⟶ n(L) * x ≤ n(x ⊓ L) * top" nitpick [expect=genuine,card=3] oops
lemma "x ⊓ L ≤ n(x) * top" nitpick [expect=genuine,card=3] oops
lemma n_meet_comp: "n(x) ⊓ n(y) ≤ n(x) * n(y)" nitpick [expect=genuine,card=3] oops

lemma n_n_meet_L_n_zero: "n(x) = (n(x) ⊓ L) ⊔ n(x * bot)" oops
lemma n_below_n_zero: "n(x) ≤ x ⊔ n(x * bot)" oops
lemma n_n_top_split_n_L_n_zero_top: "n(x) * top = n(x) * L ⊔ n(x * bot) * top" oops
lemma n_meet_L_0_0_meet_L: "(x ⊓ L) * bot = x * bot ⊓ L" oops
*)

end

end

Theory Recursion

(* Title:      Recursion
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Recursion›

theory Recursion

imports Approximation N_Algebras

begin

class n_algebra_apx = n_algebra + apx +
  assumes apx_def: "x ⊑ y ⟷ x ≤ y ⊔ L ∧ C y ≤ x ⊔ n(x) * top"
begin

lemma apx_transitive_2:
  assumes "x ⊑ y"
      and "y ⊑ z"
    shows "x ⊑ z"
proof -
  have "C z ≤ C (y ⊔ n(y) * top)"
    using assms(2) apx_def le_inf_iff by blast
  also have "... = C y ⊔ n(y) * top"
    by (simp add: C_n_mult_closed inf_sup_distrib1)
  also have "... ≤ x ⊔ n(x) * top ⊔ n(y) * top"
    using assms(1) apx_def sup_left_isotone by blast
  also have "... = x ⊔ n(x) * top ⊔ n(C y) * top"
    by (simp add: n_C)
  also have "... ≤ x ⊔ n(x) * top"
    by (metis assms(1) sup_assoc sup_idem sup_right_isotone apx_def mult_left_isotone n_add_n_top n_isotone)
  finally show ?thesis
    by (smt assms sup_assoc sup_commute apx_def le_iff_sup)
qed

lemma apx_meet_L:
  assumes "y ⊑ x"
    shows "x ⊓ L ≤ y ⊓ L"
proof -
  have "x ⊓ L = C x ⊓ L"
    by (simp add: inf.left_commute inf.sup_monoid.add_assoc n_L_top_meet_L)
  also have "... ≤ (y ⊔ n(y) * top) ⊓ L"
    using assms apx_def inf.sup_left_isotone by blast
  also have "... = (y ⊓ L) ⊔ (n(y) * top ⊓ L)"
    by (simp add: inf_sup_distrib2)
  also have "... ≤ (y ⊓ L) ⊔ n(y ⊓ L) * top"
    using n_n_meet_L sup_right_isotone by force
  finally show ?thesis
    by (metis le_iff_sup inf_le2 n_less_eq_char)
qed

text ‹AACP Theorem 4.1›

subclass apx_biorder
  apply unfold_locales
  apply (simp add: apx_def inf.coboundedI2)
  apply (metis sup_same_context order.antisym apx_def apx_meet_L relative_equality)
  using apx_transitive_2 by blast

lemma sup_apx_left_isotone_2:
  assumes "x ⊑ y"
    shows "x ⊔ z ⊑ y ⊔ z"
proof -
  have 1: "x ⊔ z ≤ y ⊔ z ⊔ L"
    by (smt assms sup_assoc sup_commute sup_left_isotone apx_def)
  have "C (y ⊔ z) ≤ x ⊔ n(x) * top ⊔ C z"
    using assms apx_def inf_sup_distrib1 sup_left_isotone by auto
  also have "... ≤ x ⊔ z ⊔ n(x) * top"
    using inf.coboundedI1 inf.sup_monoid.add_commute sup.cobounded1 sup.cobounded2 sup_assoc sup_least sup_right_isotone by auto
  also have "... ≤ x ⊔ z ⊔ n(x ⊔ z) * top"
    using mult_isotone n_left_upper_bound semiring.add_left_mono by force
  finally show ?thesis
    using 1 apx_def by blast
qed

lemma mult_apx_left_isotone_2:
  assumes "x ⊑ y"
    shows "x * z ⊑ y * z"
proof -
  have "x * z ≤ y * z ⊔ L * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  hence 1: "x * z ≤ y * z ⊔ L"
    using n_L_below_L order_lesseq_imp semiring.add_left_mono by blast
  have "C (y * z) = C y * z"
    by (simp add: n_L_T_meet_mult)
  also have "... ≤ x * z ⊔ n(x) * top * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  also have "... ≤ x * z ⊔ n(x * z) * top"
    by (simp add: n_top_split)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

lemma mult_apx_right_isotone_2:
  assumes "x ⊑ y"
    shows "z * x ⊑ z * y"
proof -
  have "z * x ≤ z * y ⊔ z * L"
    by (metis assms apx_def mult_left_dist_sup mult_right_isotone)
  also have "... ≤ z * y ⊔ z * bot ⊔ L"
    using n_L_split_L semiring.add_left_mono sup_assoc by presburger
  finally have 1: "z * x ≤ z * y ⊔ L"
    using mult_right_isotone sup.absorb_iff1 by auto
  have "C (z * y) ≤ z * C y"
    by (simp add: n_L_T_meet_mult n_L_T_meet_mult_propagate)
  also have "... ≤ z * (x ⊔ n(x) * top)"
    using assms apx_def mult_right_isotone by blast
  also have "... = z * x ⊔ z * n(x) * top"
    by (simp add: mult_left_dist_sup mult_assoc)
  also have "... ≤ z * x ⊔ n(z * x) * top"
    by (simp add: n_split_top)
  finally show ?thesis
    using 1 apx_def by blast
qed

text ‹AACP Theorem 4.1 and Theorem 4.2›

subclass apx_semiring
  apply unfold_locales
  apply (simp add: apx_def n_L_below_nL_top sup.absorb2)
  using sup_apx_left_isotone_2 apply blast
  using mult_apx_left_isotone_2 apply blast
  by (simp add: mult_apx_right_isotone_2)

text ‹AACP Theorem 4.2›

lemma meet_L_apx_isotone:
  "x ⊑ y ⟹ x ⊓ L ⊑ y ⊓ L"
  by (smt (verit) apx_meet_L apx_def inf.cobounded2 inf.left_commute n_L_top_meet_L n_less_eq_char sup.absorb2)

text ‹AACP Theorem 4.2›

lemma n_L_apx_isotone:
  assumes "x ⊑ y"
    shows "n(x) * L ⊑ n(y) * L"
proof -
  have "C (n(y) * L) ≤ n(C y) * L"
    by (simp add: n_C)
  also have "... ≤ n(x) * L ⊔ n(n(x) * L) * top"
    by (metis assms apx_def n_add_n_top n_galois n_isotone n_n_L)
  finally show ?thesis
    using apx_def le_inf_iff n_L_decreasing_meet_L sup.absorb2 by auto
qed

definition kappa_apx_meet :: "('a ⇒ 'a) ⇒ bool"
  where "kappa_apx_meet f ≡ apx.has_least_fixpoint f ∧ has_apx_meet (μ f) (ν f) ∧ κ f = μ f △ ν f"

definition kappa_mu_nu :: "('a ⇒ 'a) ⇒ bool"
  where "kappa_mu_nu f ≡ apx.has_least_fixpoint f ∧ κ f = μ f ⊔ (ν f ⊓ L)"

definition nu_below_mu_nu :: "('a ⇒ 'a) ⇒ bool"
  where "nu_below_mu_nu f ≡ C (ν f) ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(ν f) * top"

definition nu_below_mu_nu_2 :: "('a ⇒ 'a) ⇒ bool"
  where "nu_below_mu_nu_2 f ≡ C (ν f) ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(μ f ⊔ (ν f ⊓ L)) * top"

definition mu_nu_apx_nu :: "('a ⇒ 'a) ⇒ bool"
  where "mu_nu_apx_nu f ≡ μ f ⊔ (ν f ⊓ L) ⊑ ν f"

definition mu_nu_apx_meet :: "('a ⇒ 'a) ⇒ bool"
  where "mu_nu_apx_meet f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f = μ f ⊔ (ν f ⊓ L)"

definition apx_meet_below_nu :: "('a ⇒ 'a) ⇒ bool"
  where "apx_meet_below_nu f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f ≤ ν f"

lemma mu_below_l:
  "μ f ≤ μ f ⊔ (ν f ⊓ L)"
  by simp

lemma l_below_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ μ f ⊔ (ν f ⊓ L) ≤ ν f"
  by (simp add: mu_below_nu)

lemma n_l_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ (μ f ⊔ (ν f ⊓ L)) ⊓ L = ν f ⊓ L"
  by (meson l_below_nu inf.cobounded1 inf.sup_same_context order_trans sup_ge2)

lemma l_apx_mu:
  "μ f ⊔ (ν f ⊓ L) ⊑ μ f"
proof -
  have 1: "μ f ⊔ (ν f ⊓ L) ≤ μ f ⊔ L"
    using sup_right_isotone by auto
  have "C (μ f) ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(μ f ⊔ (ν f ⊓ L)) * top"
    by (simp add: le_supI1)
  thus ?thesis
    using 1 apx_def by blast
qed

text ‹AACP Theorem 4.8 implies Theorem 4.9›

lemma nu_below_mu_nu_nu_below_mu_nu_2:
  assumes "nu_below_mu_nu f"
    shows "nu_below_mu_nu_2 f"
proof -
  have "C (ν f) = C (C (ν f))"
    by auto
  also have "... ≤ C (μ f ⊔ (ν f ⊓ L) ⊔ n(ν f) * top)"
    using assms nu_below_mu_nu_def by auto
  also have "... = C (μ f ⊔ (ν f ⊓ L)) ⊔ C (n(ν f) * top)"
    using inf_sup_distrib1 by auto
  also have "... = C (μ f ⊔ (ν f ⊓ L)) ⊔ n(ν f) * top"
    by (simp add: C_n_mult_closed)
  also have "... ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(ν f) * top"
    using inf_le2 sup_left_isotone by blast
  also have "... = μ f ⊔ (ν f ⊓ L) ⊔ n(ν f ⊓ L) * top"
    using n_n_meet_L by auto
  also have "... ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(μ f ⊔ (ν f ⊓ L)) * top"
    using mult_isotone n_right_upper_bound semiring.add_left_mono by auto
  finally show ?thesis
    by (simp add: nu_below_mu_nu_2_def)
qed

text ‹AACP Theorem 4.9 implies Theorem 4.8›

lemma nu_below_mu_nu_2_nu_below_mu_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "nu_below_mu_nu_2 f"
    shows "nu_below_mu_nu f"
proof -
  have "C (ν f) ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(μ f ⊔ (ν f ⊓ L)) * top"
    using assms(3) nu_below_mu_nu_2_def by blast
  also have "... ≤ μ f ⊔ (ν f ⊓ L) ⊔ n(ν f) * top"
    by (metis assms(1,2) order.eq_iff n_n_meet_L n_l_nu)
  finally show ?thesis
    using nu_below_mu_nu_def by blast
qed

lemma nu_below_mu_nu_equivalent:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ (nu_below_mu_nu f ⟷ nu_below_mu_nu_2 f)"
  using nu_below_mu_nu_2_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by blast

text ‹AACP Theorem 4.9 implies Theorem 4.10›

lemma nu_below_mu_nu_2_mu_nu_apx_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "nu_below_mu_nu_2 f"
    shows "mu_nu_apx_nu f"
proof -
  have "μ f ⊔ (ν f ⊓ L) ≤ ν f ⊔ L"
    using assms(1,2) l_below_nu le_supI1 by blast
  thus ?thesis
    using assms(3) apx_def mu_nu_apx_nu_def nu_below_mu_nu_2_def by blast
qed

text ‹AACP Theorem 4.10 implies Theorem 4.11›

lemma mu_nu_apx_nu_mu_nu_apx_meet:
  assumes "mu_nu_apx_nu f"
    shows "mu_nu_apx_meet f"
proof -
  let ?l = "μ f ⊔ (ν f ⊓ L)"
  have "is_apx_meet (μ f) (ν f) ?l"
  proof (unfold is_apx_meet_def, intro conjI)
    show "?l ⊑ μ f"
      by (simp add: l_apx_mu)
    show "?l ⊑ ν f"
      using assms mu_nu_apx_nu_def by blast
    show "∀w. w ⊑ μ f ∧ w ⊑ ν f ⟶ w ⊑ ?l"
      by (metis apx_meet_L le_inf_iff sup.absorb1 sup_apx_left_isotone)
  qed
  thus ?thesis
    by (simp add: apx_meet_char mu_nu_apx_meet_def)
qed

text ‹AACP Theorem 4.11 implies Theorem 4.12›

lemma mu_nu_apx_meet_apx_meet_below_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ mu_nu_apx_meet f ⟹ apx_meet_below_nu f"
  using apx_meet_below_nu_def l_below_nu mu_nu_apx_meet_def by auto

text ‹AACP Theorem 4.12 implies Theorem 4.9›

lemma apx_meet_below_nu_nu_below_mu_nu_2:
  assumes "apx_meet_below_nu f"
    shows "nu_below_mu_nu_2 f"
proof -
  let ?l = "μ f ⊔ (ν f ⊓ L)"
  have "∀m . m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f ⟶ C (ν f) ≤ ?l ⊔ n(?l) * top"
  proof
    fix m
    show "m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f ⟶ C (ν f) ≤ ?l ⊔ n(?l) * top"
    proof
      assume 1: "m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f"
      hence "m ≤ ?l"
        by (smt (z3) apx_def sup.left_commute sup_inf_distrib1 sup_left_divisibility)
      hence "m ⊔ n(m) * top ≤ ?l ⊔ n(?l) * top"
        by (metis sup_mono mult_left_isotone n_isotone)
      thus "C (ν f) ≤ ?l ⊔ n(?l) * top"
        using 1 apx_def order.trans by blast
    qed
  qed
  thus ?thesis
    by (smt (verit, ccfv_threshold) assms apx_meet_below_nu_def apx_meet_same apx_meet_unique is_apx_meet_def nu_below_mu_nu_2_def)
qed

text ‹AACP Theorem 4.5 implies Theorem 4.6›

lemma has_apx_least_fixpoint_kappa_apx_meet:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "apx.has_least_fixpoint f"
    shows "kappa_apx_meet f"
proof -
  have 1: "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ C (κ f) ≤ w ⊔ n(w) * top"
    by (metis assms(2,3) apx_def inf.sup_right_isotone order_trans kappa_below_nu)
  have "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ w ≤ κ f ⊔ L"
    by (metis assms(1,3) sup_left_isotone apx_def mu_below_kappa order_trans)
  hence "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ w ⊑ κ f"
    using 1 apx_def by blast
  hence "is_apx_meet (μ f) (ν f) (κ f)"
    by (simp add: assms is_apx_meet_def kappa_apx_below_mu kappa_apx_below_nu)
  thus ?thesis
    by (simp add: assms(3) kappa_apx_meet_def apx_meet_char)
qed

text ‹AACP Theorem 4.6 implies Theorem 4.12›

lemma kappa_apx_meet_apx_meet_below_nu:
  "has_greatest_fixpoint f ⟹ kappa_apx_meet f ⟹ apx_meet_below_nu f"
  using apx_meet_below_nu_def kappa_apx_meet_def kappa_below_nu by force

text ‹AACP Theorem 4.12 implies Theorem 4.7›

lemma apx_meet_below_nu_kappa_mu_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "isotone f"
      and "apx.isotone f"
      and "apx_meet_below_nu f"
    shows "kappa_mu_nu f"
proof -
  let ?l = "μ f ⊔ (ν f ⊓ L)"
  let ?m = "μ f △ ν f"
  have 1: "?m = ?l"
    by (metis assms(1,2,5) apx_meet_below_nu_nu_below_mu_nu_2 mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu)
  have 2: "?l ≤ f(?l) ⊔ L"
  proof -
    have "?l ≤ μ f ⊔ L"
      using sup_right_isotone by auto
    also have "... = f(μ f) ⊔ L"
      by (simp add: assms(1) mu_unfold)
    also have "... ≤ f(?l) ⊔ L"
      using assms(3) isotone_def sup_ge1 sup_left_isotone by blast
    finally show "?l ≤ f(?l) ⊔ L"
      .
  qed
  have "C (f(?l)) ≤ ?l ⊔ n(?l) * top"
  proof -
    have "C (f(?l)) ≤ C (f(ν f))"
      using assms(1-3) l_below_nu inf.sup_right_isotone isotone_def by blast
    also have "... = C (ν f)"
      by (metis assms(2) nu_unfold)
    also have "... ≤ ?l ⊔ n(?l) * top"
      by (metis assms(5) apx_meet_below_nu_nu_below_mu_nu_2 nu_below_mu_nu_2_def)
    finally show "C (f(?l)) ≤ ?l ⊔ n(?l) * top"
      .
  qed
  hence 3: "?l ⊑ f(?l)"
    using 2 apx_def by blast
  have 4: "f(?l) ⊑ μ f"
  proof -
    have "?l ⊑ μ f"
      by (simp add: l_apx_mu)
    thus "f(?l) ⊑ μ f"
      by (metis assms(1,4) mu_unfold ord.isotone_def)
  qed
  have "f(?l) ⊑ ν f"
  proof -
    have "?l ⊑ ν f"
      using 1
      by (metis apx_meet_below_nu_def assms(5) apx_meet is_apx_meet_def)
    thus "f(?l) ⊑ ν f"
      by (metis assms(2,4) nu_unfold ord.isotone_def)
  qed
  hence "f(?l) ⊑ ?l"
    using 1 4 apx_meet_below_nu_def assms(5) apx_meet is_apx_meet_def by fastforce
  hence 5: "f(?l) = ?l"
    using 3 apx.order.antisym by blast
  have "∀y . f(y) = y ⟶ ?l ⊑ y"
  proof
    fix y
    show "f(y) = y ⟶ ?l ⊑ y"
    proof
      assume 6: "f(y) = y"
      hence 7: "?l ≤ y ⊔ L"
        using assms(1) inf.cobounded2 is_least_fixpoint_def least_fixpoint semiring.add_mono by blast
      have "y ≤ ν f"
        using 6 assms(2) greatest_fixpoint is_greatest_fixpoint_def by auto
      hence "C y ≤ ?l ⊔ n(?l) * top"
        using assms(5) apx_meet_below_nu_nu_below_mu_nu_2 inf.sup_right_isotone nu_below_mu_nu_2_def order_trans by blast
      thus "?l ⊑ y"
        using 7 apx_def by blast
    qed
  qed
  thus ?thesis
    using 5 apx.least_fixpoint_same apx.has_least_fixpoint_def apx.is_least_fixpoint_def kappa_mu_nu_def by auto
qed

text ‹AACP Theorem 4.7 implies Theorem 4.5›

lemma kappa_mu_nu_has_apx_least_fixpoint:
  "kappa_mu_nu f ⟹ apx.has_least_fixpoint f"
  by (simp add: kappa_mu_nu_def)

text ‹AACP Theorem 4.8 implies Theorem 4.7›

lemma nu_below_mu_nu_kappa_mu_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ isotone f ⟹ apx.isotone f ⟹ nu_below_mu_nu f ⟹ kappa_mu_nu f"
  using apx_meet_below_nu_kappa_mu_nu mu_nu_apx_meet_apx_meet_below_nu mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_nu_below_mu_nu_2 by blast

text ‹AACP Theorem 4.7 implies Theorem 4.8›

lemma kappa_mu_nu_nu_below_mu_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ kappa_mu_nu f ⟹ nu_below_mu_nu f"
  by (simp add: apx_meet_below_nu_nu_below_mu_nu_2 has_apx_least_fixpoint_kappa_apx_meet kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_has_apx_least_fixpoint nu_below_mu_nu_2_nu_below_mu_nu)

definition kappa_mu_nu_L :: "('a ⇒ 'a) ⇒ bool"
  where "kappa_mu_nu_L f ≡ apx.has_least_fixpoint f ∧ κ f = μ f ⊔ n(ν f) * L"

definition nu_below_mu_nu_L :: "('a ⇒ 'a) ⇒ bool"
  where "nu_below_mu_nu_L f ≡ C (ν f) ≤ μ f ⊔ n(ν f) * top"

definition mu_nu_apx_nu_L :: "('a ⇒ 'a) ⇒ bool"
  where "mu_nu_apx_nu_L f ≡ μ f ⊔ n(ν f) * L ⊑ ν f"

definition mu_nu_apx_meet_L :: "('a ⇒ 'a) ⇒ bool"
  where "mu_nu_apx_meet_L f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f = μ f ⊔ n(ν f) * L"

lemma n_below_l:
  "x ⊔ n(y) * L ≤ x ⊔ (y ⊓ L)"
  using n_L_decreasing_meet_L semiring.add_left_mono by auto

lemma n_equal_l:
  assumes "nu_below_mu_nu_L f"
    shows "μ f ⊔ n(ν f) * L = μ f ⊔ (ν f ⊓ L)"
proof -
  have "ν f ⊓ L ≤ (μ f ⊔ n(ν f) * top) ⊓ L"
    by (meson assms order.trans inf.boundedI inf.cobounded2 meet_L_below_C nu_below_mu_nu_L_def)
  also have "... ≤ μ f ⊔ (n(ν f) * top ⊓ L)"
    by (simp add: inf.coboundedI2 inf.sup_monoid.add_commute inf_sup_distrib1)
  also have "... ≤ μ f ⊔ n(ν f) * L"
    by (simp add: n_T_meet_L)
  finally have "μ f ⊔ (ν f ⊓ L) ≤ μ f ⊔ n(ν f) * L"
    by simp
  thus "μ f ⊔ n(ν f) * L = μ f ⊔ (ν f ⊓ L)"
    by (meson order.antisym n_below_l)
qed

text ‹AACP Theorem 4.14 implies Theorem 4.8›

lemma nu_below_mu_nu_L_nu_below_mu_nu:
  "nu_below_mu_nu_L f ⟹ nu_below_mu_nu f"
  by (metis sup_assoc sup_right_top mult_left_dist_sup n_equal_l nu_below_mu_nu_L_def nu_below_mu_nu_def)

text ‹AACP Theorem 4.14 implies Theorem 4.13›

lemma nu_below_mu_nu_L_kappa_mu_nu_L:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ isotone f ⟹ apx.isotone f ⟹ nu_below_mu_nu_L f ⟹ kappa_mu_nu_L f"
  using kappa_mu_nu_L_def kappa_mu_nu_def n_equal_l nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_kappa_mu_nu by force

text ‹AACP Theorem 4.14 implies Theorem 4.15›

lemma nu_below_mu_nu_L_mu_nu_apx_nu_L:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ nu_below_mu_nu_L f ⟹ mu_nu_apx_nu_L f"
  using mu_nu_apx_nu_L_def mu_nu_apx_nu_def n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by auto

text ‹AACP Theorem 4.14 implies Theorem 4.16›

lemma nu_below_mu_nu_L_mu_nu_apx_meet_L:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ nu_below_mu_nu_L f ⟹ mu_nu_apx_meet_L f"
  using mu_nu_apx_meet_L_def mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by auto

text ‹AACP Theorem 4.15 implies Theorem 4.14›

lemma mu_nu_apx_nu_L_nu_below_mu_nu_L:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "mu_nu_apx_nu_L f"
    shows "nu_below_mu_nu_L f"
proof -
  let ?n = "μ f ⊔ n(ν f) * L"
  let ?l = "μ f ⊔ (ν f ⊓ L)"
  have "C (ν f) ≤ ?n ⊔ n(?n) * top"
    using assms(3) apx_def mu_nu_apx_nu_L_def by blast
  also have "... ≤ ?n ⊔ n(?l) * top"
    using mult_left_isotone n_L_decreasing_meet_L n_isotone semiring.add_left_mono by auto
  also have "... ≤ ?n ⊔ n(ν f) * top"
    using assms(1,2) l_below_nu mult_left_isotone n_isotone sup_right_isotone by auto
  finally show ?thesis
    by (metis sup_assoc sup_right_top mult_left_dist_sup nu_below_mu_nu_L_def)
qed

text ‹AACP Theorem 4.13 implies Theorem 4.15›

lemma kappa_mu_nu_L_mu_nu_apx_nu_L:
  "has_greatest_fixpoint f ⟹ kappa_mu_nu_L f ⟹ mu_nu_apx_nu_L f"
  using kappa_mu_nu_L_def kappa_apx_below_nu mu_nu_apx_nu_L_def by fastforce

text ‹AACP Theorem 4.16 implies Theorem 4.15›

lemma mu_nu_apx_meet_L_mu_nu_apx_nu_L:
  "mu_nu_apx_meet_L f ⟹ mu_nu_apx_nu_L f"
  using apx_meet_char is_apx_meet_def mu_nu_apx_meet_L_def mu_nu_apx_nu_L_def by fastforce

text ‹AACP Theorem 4.13 implies Theorem 4.14›

lemma kappa_mu_nu_L_nu_below_mu_nu_L:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ kappa_mu_nu_L f ⟹ nu_below_mu_nu_L f"
  by (simp add: kappa_mu_nu_L_mu_nu_apx_nu_L mu_nu_apx_nu_L_nu_below_mu_nu_L)

(*
lemma nu_below_mu_nu_nu_below_mu_nu_L: "nu_below_mu_nu f ⟶ nu_below_mu_nu_L f" nitpick [expect=genuine,card=3] oops
*)

lemma unfold_fold_1:
  "isotone f ⟹ has_least_prefixpoint f ⟹ apx.has_least_fixpoint f ⟹ f(x) ≤ x ⟹ κ f ≤ x ⊔ L"
  by (metis sup_left_isotone apx_def has_least_fixpoint_def is_least_prefixpoint_def least_prefixpoint_char least_prefixpoint_fixpoint order_trans pmu_mu kappa_apx_below_mu)

lemma unfold_fold_2:
  assumes "isotone f"
      and "apx.isotone f"
      and "has_least_prefixpoint f"
      and "has_greatest_fixpoint f"
      and "apx.has_least_fixpoint f"
      and "f(x) ≤ x"
      and "κ f ⊓ L ≤ x ⊓ L"
    shows "κ f ≤ x"
proof -
  have "κ f ⊓ L = ν f ⊓ L"
    by (smt (z3) apx_meet_L assms(4,5) order.eq_iff inf.cobounded1 kappa_apx_below_nu kappa_below_nu le_inf_iff)
  hence "κ f = (κ f ⊓ L) ⊔ μ f"
    by (metis assms(1-5) apx_meet_below_nu_kappa_mu_nu has_apx_least_fixpoint_kappa_apx_meet sup_commute least_fixpoint_char least_prefixpoint_fixpoint kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_def)
  thus ?thesis
    by (metis assms(1,3,6,7) sup_least is_least_prefixpoint_def least_prefixpoint le_inf_iff pmu_mu)
qed

end

class n_algebra_apx_2 = n_algebra + apx +
  assumes apx_def: "x ⊑ y ⟷ x ≤ y ⊔ L ∧ y ≤ x ⊔ n(x) * top"
begin

lemma apx_transitive_2:
  assumes "x ⊑ y"
      and "y ⊑ z"
    shows "x ⊑ z"
proof -
  have "z ≤ y ⊔ n(y) * top"
    using assms(2) apx_def by auto
  also have "... ≤ x ⊔ n(x) * top ⊔ n(y) * top"
    using assms(1) apx_def sup_left_isotone by blast
  also have "... ≤ x ⊔ n(x) * top"
    by (metis assms(1) sup_assoc sup_idem sup_right_isotone apx_def mult_left_isotone n_add_n_top n_isotone)
  finally show ?thesis
    by (smt assms sup_assoc sup_commute apx_def le_iff_sup)
qed

lemma apx_meet_L:
  assumes "y ⊑ x"
    shows "x ⊓ L ≤ y ⊓ L"
proof -
  have "x ⊓ L ≤ (y ⊓ L) ⊔ (n(y) * top ⊓ L)"
    by (metis assms apx_def inf.sup_left_isotone inf_sup_distrib2)
  also have "... ≤ (y ⊓ L) ⊔ n(y ⊓ L) * top"
    using n_n_meet_L sup_right_isotone by force
  finally show ?thesis
    by (metis le_iff_sup inf_le2 n_less_eq_char)
qed

text ‹AACP Theorem 4.1›

subclass apx_biorder
  apply unfold_locales
  apply (simp add: apx_def)
  using apx_def order.eq_iff n_less_eq_char apply blast
  using apx_transitive_2 by blast

lemma sup_apx_left_isotone_2:
  assumes "x ⊑ y"
    shows "x ⊔ z ⊑ y ⊔ z"
proof -
  have 1: "x ⊔ z ≤ y ⊔ z ⊔ L"
    by (smt assms sup_assoc sup_commute sup_left_isotone apx_def)
  have "y ⊔ z ≤ x ⊔ n(x) * top ⊔ z"
    using assms apx_def sup_left_isotone by blast
  also have "... ≤ x ⊔ z ⊔ n(x ⊔ z) * top"
    by (metis sup_assoc sup_commute sup_right_isotone mult_left_isotone n_right_upper_bound)
  finally show ?thesis
    using 1 apx_def by auto
qed

lemma mult_apx_left_isotone_2:
  assumes "x ⊑ y"
    shows "x * z ⊑ y * z"
proof -
  have "x * z ≤ y * z ⊔ L * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  hence 1: "x * z ≤ y * z ⊔ L"
    using n_L_below_L order_lesseq_imp semiring.add_left_mono by blast
  have "y * z ≤ x * z ⊔ n(x) * top * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  also have "... ≤ x * z ⊔ n(x * z) * top"
    by (simp add: n_top_split)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

lemma mult_apx_right_isotone_2:
  assumes "x ⊑ y"
    shows "z * x ⊑ z * y"
proof -
  have "z * x ≤ z * y ⊔ z * L"
    by (metis assms apx_def mult_left_dist_sup mult_right_isotone)
  also have "... ≤ z * y ⊔ z * bot ⊔ L"
    using n_L_split_L semiring.add_left_mono sup_assoc by auto
  finally have 1: "z * x ≤ z * y ⊔ L"
    using mult_right_isotone sup.absorb_iff1 by force
  have "z * y ≤ z * (x ⊔ n(x) * top)"
    using assms apx_def mult_right_isotone by blast
  also have "... = z * x ⊔ z * n(x) * top"
    by (simp add: mult_left_dist_sup mult_assoc)
  also have "... ≤ z * x ⊔ n(z * x) * top"
    by (simp add: n_split_top)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

end

end

Theory N_Omega_Algebras

(* Title:      N-Omega-Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹N-Omega-Algebras›

theory N_Omega_Algebras

imports Omega_Algebras Recursion

begin

class itering_apx = bounded_itering + n_algebra_apx
begin

lemma circ_L:
  "L⇧^∘ = L ⊔ 1"
  by (metis sup_commute mult_top_circ n_L_top_L)

lemma C_circ_import:
  "C (x⇧^∘) ≤ (C x)⇧^∘"
proof -
  have 1: "C x * x⇧^∘ ≤ (C x)⇧^∘ * C x"
    using C_mult_propagate circ_simulate order.eq_iff by blast
  have "C (x⇧^∘) = C (1 ⊔ x * x⇧^∘)"
    by (simp add: circ_left_unfold)
  also have "... = C 1 ⊔ C (x * x⇧^∘)"
    by (simp add: inf_sup_distrib1)
  also have "... ≤ 1 ⊔ C (x * x⇧^∘)"
    using sup_left_isotone by auto
  also have "... = 1 ⊔ C x * x⇧^∘"
    by (simp add: n_L_T_meet_mult)
  also have "... ≤ (C x)⇧^∘"
    using 1 by (meson circ_reflexive order.trans le_supI right_plus_below_circ)
  finally show ?thesis
    .
qed

text ‹AACP Theorem 4.3 and Theorem 4.4›

lemma circ_apx_isotone:
  assumes "x ⊑ y"
  shows "x⇧^∘ ⊑ y⇧^∘"
proof -
  have 1: "x ≤ y ⊔ L ∧ C y ≤ x ⊔ n(x) * top"
    using assms apx_def by auto
  have "C (y⇧^∘) ≤ (C y)⇧^∘"
    by (simp add: C_circ_import)
  also have "... ≤ x⇧^∘ ⊔ x⇧^∘ * n(x) * top"
    using 1 by (metis circ_isotone circ_left_top circ_unfold_sum mult_assoc)
  also have "... ≤ x⇧^∘ ⊔ (x⇧^∘ * bot ⊔ n(x⇧^∘ * x) * top)"
    using n_n_top_split_n_top sup_right_isotone by blast
  also have "... ≤ x⇧^∘ ⊔ (x⇧^∘ * bot ⊔ n(x⇧^∘) * top)"
    using circ_plus_same left_plus_below_circ mult_left_isotone n_isotone sup_right_isotone by auto
  also have "... = x⇧^∘ ⊔ n(x⇧^∘) * top"
    by (meson sup.left_idem sup_relative_same_increasing zero_right_mult_decreasing)
  finally have 2: "C (y⇧^∘) ≤ x⇧^∘ ⊔ n(x⇧^∘) * top"
    .
  have "x⇧^∘ ≤ y⇧^∘ * L⇧^∘"
    using 1 by (metis circ_sup_1 circ_back_loop_fixpoint circ_isotone n_L_below_L le_iff_sup mult_assoc)
  also have "... = y⇧^∘ ⊔ y⇧^∘ * L"
    using circ_L mult_left_dist_sup sup_commute by auto
  also have "... ≤ y⇧^∘ ⊔ y⇧^∘ * bot ⊔ L"
    using n_L_split_L semiring.add_left_mono sup_assoc by auto
  finally have "x⇧^∘ ≤ y⇧^∘ ⊔ L"
    using sup.absorb1 zero_right_mult_decreasing by force
  thus "x⇧^∘ ⊑ y⇧^∘"
    using 2 by (simp add: apx_def)
qed

end

class n_omega_algebra_1 = bounded_left_zero_omega_algebra + n_algebra_apx + Omega +
  assumes Omega_def: "x⇧^Ω = n(x⇧^ω) * L ⊔ x⇧^⋆"
begin

text ‹AACP Theorem 8.13›

lemma C_omega_export:
  "C (x⇧^ω) = (C x)⇧^ω"
proof -
  have "C (x⇧^ω) = C x * C (x⇧^ω)"
    by (metis C_mult_propagate n_L_T_meet_mult omega_unfold)
  hence 1: "C (x⇧^ω) ≤ (C x)⇧^ω"
    using eq_refl omega_induct_mult by auto
  have "(C x)⇧^ω = C (x * (C x)⇧^ω)"
    using n_L_T_meet_mult omega_unfold by auto
  also have "... ≤ C (x⇧^ω)"
    by (metis calculation C_decreasing inf_le1 le_infI omega_induct_mult)
  finally show ?thesis
    using 1 order.antisym by blast
qed  

text ‹AACP Theorem 8.2›

lemma L_mult_star:
  "L * x⇧^⋆ = L"
  by (metis n_L_top_L star.circ_left_top mult_assoc)

text ‹AACP Theorem 8.3›

lemma mult_L_star:
  "(x * L)⇧^⋆ = 1 ⊔ x * L"
  by (metis L_mult_star star.circ_mult_1 mult_assoc)

lemma mult_L_omega_below:
  "(x * L)⇧^ω ≤ x * L"
  by (metis mult_right_isotone n_L_below_L omega_slide)

text ‹AACP Theorem 8.5›

lemma mult_L_sup_star:
  "(x * L ⊔ y)⇧^⋆ = y⇧^⋆ ⊔ y⇧^⋆ * x * L"
  using L_mult_star mult_1_right mult_left_dist_sup star_sup_1 sup_commute mult_L_star mult_assoc by auto

lemma mult_L_sup_omega_below:
  "(x * L ⊔ y)⇧^ω ≤ y⇧^ω ⊔ y⇧^⋆ * x * L"
proof -
  have "(x * L ⊔ y)⇧^ω ≤ y⇧^⋆ * x * L ⊔ (y⇧^⋆ * x * L)⇧^⋆ * y⇧^ω"
    by (metis sup_commute mult_assoc omega_decompose sup_left_isotone mult_L_omega_below)
  also have "... ≤ y⇧^ω ⊔ y⇧^⋆ * x * L"
    by (smt (z3) le_iff_sup le_supI mult_left_dist_sup n_L_below_L star_left_induct sup.cobounded2 sup.left_idem sup.orderE sup_assoc sup_commute mult_assoc)
  finally show ?thesis
    .
qed

lemma n_Omega_isotone:
  "x ≤ y ⟹ x⇧^Ω ≤ y⇧^Ω"
  by (metis Omega_def sup_mono mult_left_isotone n_isotone omega_isotone star_isotone)

lemma n_star_below_Omega:
  "x⇧^⋆ ≤ x⇧^Ω"
  by (simp add: Omega_def)

lemma mult_L_star_mult_below:
  "(x * L)⇧^⋆ * y ≤ y ⊔ x * L"
  by (metis sup_right_isotone mult_assoc mult_right_isotone n_L_below_L star_left_induct)

end

sublocale n_omega_algebra_1 < star: itering_apx where circ = star ..

class n_omega_algebra = n_omega_algebra_1 + n_algebra_apx +
  assumes n_split_omega_mult: "C (x⇧^ω) ≤ x⇧^⋆ * n(x⇧^ω) * top"
  assumes tarski: "x * L ≤ x * L * x * L"
begin

text ‹AACP Theorem 8.4›

lemma mult_L_omega:
  "(x * L)⇧^ω = x * L"
  apply (rule order.antisym)
  apply (rule mult_L_omega_below)
  using omega_induct_mult tarski mult_assoc by auto

text ‹AACP Theorem 8.6›

lemma mult_L_sup_omega:
  "(x * L ⊔ y)⇧^ω = y⇧^ω ⊔ y⇧^⋆ * x * L"
  apply (rule order.antisym)
  apply (rule mult_L_sup_omega_below)
  by (metis le_supI omega_isotone omega_sub_dist_2 sup.cobounded2 sup_commute mult_L_omega mult_assoc)

text ‹AACP Theorem 8.1›

lemma tarski_mult_top_idempotent:
  "x * L = x * L * x * L"
  by (metis omega_unfold mult_L_omega mult_assoc)

text ‹AACP Theorem 8.7›

lemma n_below_n_omega:
  "n(x) ≤ n(x⇧^ω)"
proof -
  have "n(x) * L ≤ n(x) * L * n(x) * L"
    by (simp add: tarski)
  also have "... ≤ x * n(x) * L"
    by (simp add: mult_isotone n_L_decreasing)
  finally have "n(x) * L ≤ x⇧^ω"
    by (simp add: omega_induct_mult mult_assoc)
  thus ?thesis
    by (simp add: n_galois)
qed

text ‹AACP Theorem 8.14›

lemma n_split_omega_sup_zero:
  "C (x⇧^ω) ≤ x⇧^⋆ * bot ⊔ n(x⇧^ω) * top"
proof -
  have "n(x⇧^ω) * top ⊔ x * (x⇧^⋆ * bot ⊔ n(x⇧^ω) * top) = n(x⇧^ω) * top ⊔ x * x⇧^⋆ * bot ⊔ x * n(x⇧^ω) * top"
    by (simp add: mult_left_dist_sup sup_assoc mult_assoc)
  also have "... ≤ n(x⇧^ω) * top ⊔ x * x⇧^⋆ * bot ⊔ x * bot ⊔ n(x⇧^ω) * top"
    by (metis sup_assoc sup_right_isotone n_n_top_split_n_top omega_unfold)
  also have "... = x * x⇧^⋆ * bot ⊔ n(x⇧^ω) * top"
    by (smt sup_assoc sup_commute sup_left_top sup_bot_right mult_assoc mult_left_dist_sup)
  also have "... ≤ x⇧^⋆ * bot ⊔ n(x⇧^ω) * top"
    by (metis sup_left_isotone mult_left_isotone star.left_plus_below_circ)
  finally have "x⇧^⋆ * n(x⇧^ω) * top ≤ x⇧^⋆ * bot ⊔ n(x⇧^ω) * top"
    using star_left_induct mult_assoc by auto
  thus ?thesis
    using n_split_omega_mult order_trans by blast
qed

lemma n_split_omega_sup:
  "C (x⇧^ω) ≤ x⇧^⋆ ⊔ n(x⇧^ω) * top"
  by (metis sup_left_isotone n_split_omega_sup_zero order_trans zero_right_mult_decreasing)

text ‹AACP Theorem 8.12›

lemma n_dist_omega_star:
  "n(y⇧^ω ⊔ y⇧^⋆ * z) = n(y⇧^ω) ⊔ n(y⇧^⋆ * z)"
proof -
  have "n(y⇧^ω ⊔ y⇧^⋆ * z) = n(C (y⇧^ω) ⊔ C (y⇧^⋆ * z))"
    by (metis inf_sup_distrib1 n_C)
  also have "... ≤ n(C (y⇧^ω) ⊔ y⇧^⋆ * z)"
    using n_isotone semiring.add_right_mono sup_commute by auto
  also have "... ≤ n(y⇧^⋆ * bot ⊔ n(y⇧^ω) * top ⊔ y⇧^⋆ * z)"
    using n_isotone semiring.add_right_mono n_split_omega_sup_zero by blast
  also have "... = n(y⇧^ω) ⊔ n(y⇧^⋆ * z)"
    by (smt sup_assoc sup_commute sup_bot_right mult_left_dist_sup n_dist_n_add)
  finally show ?thesis
    by (simp add: order.antisym n_isotone)
qed

lemma mult_L_sup_circ_below:
  "(x * L ⊔ y)⇧^Ω ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ ⊔ y⇧^⋆ * x * L"
proof -
  have "(x * L ⊔ y)⇧^Ω ≤ n(y⇧^ω ⊔ y⇧^⋆ * x * L) * L ⊔ (x * L ⊔ y)⇧^⋆"
    by (simp add: Omega_def mult_L_sup_omega)
  also have "... = n(y⇧^ω) * L ⊔ n(y⇧^⋆ * x * L) * L ⊔ (x * L ⊔ y)⇧^⋆"
    by (simp add: semiring.distrib_right mult_assoc n_dist_omega_star)
  also have "... ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ ⊔ y⇧^⋆ * x * L"
    by (smt (z3) le_supI sup.cobounded1 sup_assoc sup_commute sup_idem sup_right_isotone mult_L_sup_star n_L_decreasing)
  finally show ?thesis
    .
qed

lemma n_mult_omega_L_below_zero:
  "n(y * x⇧^ω) * L ≤ y * x⇧^⋆ * bot ⊔ y * n(x⇧^ω) * L"
proof -
  have "n(y * x⇧^ω) * L ≤ C (y * x⇧^ω) ⊓ L"
    by (metis n_C n_L_decreasing_meet_L)
  also have "... ≤ y * C (x⇧^ω) ⊓ L"
    using inf.sup_left_isotone n_L_T_meet_mult n_L_T_meet_mult_propagate by auto
  also have "... ≤ y * (x⇧^⋆ * bot ⊔ n(x⇧^ω) * top) ⊓ L"
    using inf.sup_left_isotone mult_right_isotone n_split_omega_sup_zero by auto
  also have "... = (y * x⇧^⋆ * bot ⊓ L) ⊔ (y * n(x⇧^ω) * top ⊓ L)"
    using inf_sup_distrib2 mult_left_dist_sup mult_assoc by auto
  also have "... ≤ (y * x⇧^⋆ * bot ⊓ L) ⊔ y * n(x⇧^ω) * L"
    using n_vector_meet_L sup_right_isotone by auto
  also have "... ≤ y * x⇧^⋆ * bot ⊔ y * n(x⇧^ω) * L"
    using sup_left_isotone by auto
  finally show ?thesis
    .
qed

text ‹AACP Theorem 8.10›

lemma n_mult_omega_L_star_zero:
  "y * x⇧^⋆ * bot ⊔ n(y * x⇧^ω) * L = y * x⇧^⋆ * bot ⊔ y * n(x⇧^ω) * L"
  apply (rule order.antisym)
  apply (simp add: n_mult_omega_L_below_zero)
  by (smt sup_assoc sup_commute sup_bot_left sup_right_isotone mult_assoc mult_left_dist_sup n_n_L_split_n_L)

text ‹AACP Theorem 8.11›

lemma n_mult_omega_L_star:
  "y * x⇧^⋆ ⊔ n(y * x⇧^ω) * L = y * x⇧^⋆ ⊔ y * n(x⇧^ω) * L"
  by (metis zero_right_mult_decreasing n_mult_omega_L_star_zero sup_relative_same_increasing)

lemma n_mult_omega_L_below:
  "n(y * x⇧^ω) * L ≤ y * x⇧^⋆ ⊔ y * n(x⇧^ω) * L"
  using sup_right_divisibility n_mult_omega_L_star by blast

lemma n_omega_L_below_zero:
  "n(x⇧^ω) * L ≤ x * x⇧^⋆ * bot ⊔ x * n(x⇧^ω) * L"
  by (metis omega_unfold n_mult_omega_L_below_zero)

lemma n_omega_L_below:
  "n(x⇧^ω) * L ≤ x⇧^⋆ ⊔ x * n(x⇧^ω) * L"
  by (metis omega_unfold n_mult_omega_L_below sup_left_isotone star.left_plus_below_circ order_trans)

lemma n_omega_L_star_zero:
  "x * x⇧^⋆ * bot ⊔ n(x⇧^ω) * L = x * x⇧^⋆ * bot ⊔ x * n(x⇧^ω) * L"
  by (metis n_mult_omega_L_star_zero omega_unfold)

text ‹AACP Theorem 8.8›

lemma n_omega_L_star:
  "x⇧^⋆ ⊔ n(x⇧^ω) * L = x⇧^⋆ ⊔ x * n(x⇧^ω) * L"
  by (metis star.circ_mult_upper_bound star.left_plus_below_circ bot_least n_omega_L_star_zero sup_relative_same_increasing)

text ‹AACP Theorem 8.9›

lemma n_omega_L_star_zero_star:
  "x⇧^⋆ * bot ⊔ n(x⇧^ω) * L = x⇧^⋆ * bot ⊔ x⇧^⋆ * n(x⇧^ω) * L"
  by (metis n_mult_omega_L_star_zero star_mult_omega mult_assoc star.circ_transitive_equal)

text ‹AACP Theorem 8.8›

lemma n_omega_L_star_star:
  "x⇧^⋆ ⊔ n(x⇧^ω) * L = x⇧^⋆ ⊔ x⇧^⋆ * n(x⇧^ω) * L"
  by (metis zero_right_mult_decreasing n_omega_L_star_zero_star sup_relative_same_increasing)

lemma n_Omega_left_unfold:
  "1 ⊔ x * x⇧^Ω = x⇧^Ω"
  by (smt Omega_def sup_assoc sup_commute mult_assoc mult_left_dist_sup n_omega_L_star star.circ_left_unfold)

lemma n_Omega_left_slide:
  "(x * y)⇧^Ω * x ≤ x * (y * x)⇧^Ω"
proof -
  have "(x * y)⇧^Ω * x ≤ x * y * n((x * y)⇧^ω) * L ⊔ (x * y)⇧^⋆ * x"
    by (smt Omega_def sup_commute sup_left_isotone mult_assoc mult_right_dist_sup mult_right_isotone n_L_below_L n_omega_L_star)
  also have "... ≤ x * (y * bot ⊔ n(y * (x * y)⇧^ω) * L) ⊔ (x * y)⇧^⋆ * x"
    by (metis mult_right_isotone n_n_L_split_n_L sup_commute sup_right_isotone mult_assoc)
  also have "... = x * (y * x)⇧^Ω"
    by (smt (verit, del_insts) le_supI1 star_slide Omega_def sup_assoc sup_commute le_iff_sup mult_assoc mult_isotone mult_left_dist_sup omega_slide star.circ_increasing star.circ_slide bot_least)
  finally show ?thesis
    .
qed

lemma n_Omega_sup_1:
  "(x ⊔ y)⇧^Ω = x⇧^Ω * (y * x⇧^Ω)⇧^Ω"
proof -
  have 1: "(x ⊔ y)⇧^Ω = n((x⇧^⋆ * y)⇧^ω) * L ⊔ n((x⇧^⋆ * y)⇧^⋆ * x⇧^ω) * L ⊔ (x⇧^⋆ * y)⇧^⋆ * x⇧^⋆"
    by (simp add: Omega_def omega_decompose semiring.distrib_right star.circ_sup_9 n_dist_omega_star)
  have "n((x⇧^⋆ * y)⇧^ω) * L ≤ (x⇧^⋆ * y)⇧^⋆ ⊔ x⇧^⋆ * (y * n((x⇧^⋆ * y)⇧^ω) * L)"
    by (metis n_omega_L_below mult_assoc)
  also have "... ≤ (x⇧^⋆ * y)⇧^⋆ ⊔ x⇧^⋆ * y * bot ⊔ x⇧^⋆ * n((y * x⇧^⋆)⇧^ω) * L"
    by (smt sup_assoc sup_right_isotone mult_assoc mult_left_dist_sup mult_right_isotone n_n_L_split_n_L omega_slide)
  also have "... = (x⇧^⋆ * y)⇧^⋆ ⊔ x⇧^⋆ * n((y * x⇧^⋆)⇧^ω) * L"
    by (metis sup_commute le_iff_sup star.circ_sub_dist_1 zero_right_mult_decreasing)
  also have "... ≤ x⇧^⋆ * (y * x⇧^⋆)⇧^⋆ ⊔ x⇧^⋆ * n((y * x⇧^⋆)⇧^ω) * L"
    by (metis star_outer_increasing star_slide star_star_absorb sup_left_isotone)
  also have "... ≤ x⇧^⋆ * (y * x⇧^Ω)⇧^Ω"
    by (metis Omega_def sup_commute mult_assoc mult_left_dist_sup mult_right_isotone n_Omega_isotone n_star_below_Omega)
  also have "... ≤ x⇧^Ω * (y * x⇧^Ω)⇧^Ω"
    by (simp add: mult_left_isotone n_star_below_Omega)
  finally have 2: "n((x⇧^⋆ * y)⇧^ω) * L ≤ x⇧^Ω * (y * x⇧^Ω)⇧^Ω"
    .
  have "n((x⇧^⋆ * y)⇧^⋆ * x⇧^ω) * L ≤ n(x⇧^ω) * L ⊔ x⇧^⋆ * (y * x⇧^⋆)⇧^⋆ ⊔ x⇧^⋆ * (y * x⇧^⋆)⇧^⋆ * y * n(x⇧^ω) * L"
    by (smt sup_assoc sup_commute mult_left_one mult_right_dist_sup n_mult_omega_L_below star.circ_mult star.circ_slide)
  also have "... = n(x⇧^ω) * L * (y * x⇧^Ω)⇧^⋆ ⊔ x⇧^⋆ * (y * x⇧^Ω)⇧^⋆"
    by (smt Omega_def sup_assoc mult_L_sup_star mult_assoc mult_left_dist_sup L_mult_star)
  also have "... ≤ x⇧^Ω * (y * x⇧^Ω)⇧^Ω"
    by (simp add: Omega_def mult_isotone)
  finally have 3: "n((x⇧^⋆ * y)⇧^⋆ * x⇧^ω) * L ≤ x⇧^Ω * (y * x⇧^Ω)⇧^Ω"
    .
  have "(x⇧^⋆ * y)⇧^⋆ * x⇧^⋆ ≤ x⇧^Ω * (y * x⇧^Ω)⇧^Ω"
    by (metis star_slide mult_isotone mult_right_isotone n_star_below_Omega order_trans star_isotone)
  hence 4: "(x ⊔ y)⇧^Ω ≤ x⇧^Ω * (y * x⇧^Ω)⇧^Ω"
    using 1 2 3 by simp
  have 5: "x⇧^Ω * (y * x⇧^Ω)⇧^Ω ≤ n(x⇧^ω) * L ⊔ x⇧^⋆ * n((y * x⇧^Ω)⇧^ω) * L ⊔ x⇧^⋆ * (y * x⇧^Ω)⇧^⋆"
    by (smt Omega_def sup_assoc sup_left_isotone mult_assoc mult_left_dist_sup mult_right_dist_sup mult_right_isotone n_L_below_L)
  have "n(x⇧^ω) * L ≤ n((x⇧^⋆ * y)⇧^⋆ * x⇧^ω) * L"
    by (metis sup_commute sup_ge1 mult_left_isotone n_isotone star.circ_loop_fixpoint)
  hence 6: "n(x⇧^ω) * L ≤ (x ⊔ y)⇧^Ω"
    using 1 order_lesseq_imp by fastforce
  have "x⇧^⋆ * n((y * x⇧^Ω)⇧^ω) * L ≤ x⇧^⋆ * n((y * x⇧^⋆)⇧^ω ⊔ (y * x⇧^⋆)⇧^⋆ * y * n(x⇧^ω) * L) * L"
    by (metis Omega_def mult_L_sup_omega_below mult_assoc mult_left_dist_sup mult_left_isotone mult_right_isotone n_isotone)
  also have "... ≤ x⇧^⋆ * bot ⊔ n(x⇧^⋆ * ((y * x⇧^⋆)⇧^ω ⊔ (y * x⇧^⋆)⇧^⋆ * y * n(x⇧^ω) * L)) * L"
    by (simp add: n_n_L_split_n_L)
  also have "... ≤ x⇧^⋆ ⊔ n((x⇧^⋆ * y)⇧^ω ⊔ x⇧^⋆ * (y * x⇧^⋆)⇧^⋆ * y * n(x⇧^ω) * L) * L"
    using omega_slide semiring.distrib_left sup_mono zero_right_mult_decreasing mult_assoc by fastforce
  also have "... ≤ x⇧^⋆ ⊔ n((x⇧^⋆ * y)⇧^ω ⊔ (x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L) * L"
    by (smt sup_right_divisibility sup_right_isotone mult_left_isotone n_isotone star.circ_mult)
  also have "... ≤ x⇧^⋆ ⊔ n((x ⊔ y)⇧^ω) * L"
    by (metis sup_right_isotone mult_assoc mult_left_isotone mult_right_isotone n_L_decreasing n_isotone omega_decompose)
  also have "... ≤ (x ⊔ y)⇧^Ω"
    by (simp add: Omega_def le_supI1 star_isotone sup_commute)
  finally have 7: "x⇧^⋆ * n((y * x⇧^Ω)⇧^ω) * L ≤ (x ⊔ y)⇧^Ω"
    .
  have "x⇧^⋆ * (y * x⇧^Ω)⇧^⋆ ≤ (x⇧^⋆ * y)⇧^⋆ * x⇧^⋆ ⊔ (x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L"
    by (smt Omega_def sup_right_isotone mult_L_sup_star mult_assoc mult_left_dist_sup mult_left_isotone star.left_plus_below_circ star_slide)
  also have "... ≤ (x⇧^⋆ * y)⇧^⋆ * x⇧^⋆ ⊔ n((x⇧^⋆ * y)⇧^⋆ * x⇧^ω) * L"
    by (simp add: n_mult_omega_L_star)
  also have "... ≤ (x ⊔ y)⇧^Ω"
    by (smt Omega_def sup_commute sup_right_isotone mult_left_isotone n_right_upper_bound omega_decompose star.circ_sup)
  finally have "n(x⇧^ω) * L ⊔ x⇧^⋆ * n((y * x⇧^Ω)⇧^ω) * L ⊔ x⇧^⋆ * (y * x⇧^Ω)⇧^⋆ ≤ (x ⊔ y)⇧^Ω"
    using 6 7 by simp
  hence "x⇧^Ω * (y * x⇧^Ω)⇧^Ω ≤ (x ⊔ y)⇧^Ω"
    using 5 order.trans by blast
  thus ?thesis
    using 4 order.antisym by blast
qed

end

sublocale n_omega_algebra < nL_omega: left_zero_conway_semiring where circ = Omega
  apply unfold_locales
  apply (simp add: n_Omega_left_unfold)
  apply (simp add: n_Omega_left_slide)
  by (simp add: n_Omega_sup_1)

(* circ_plus_same does not hold in the non-strict model using Omega *)

context n_omega_algebra
begin

text ‹AACP Theorem 8.16›

lemma omega_apx_isotone:
  assumes "x ⊑ y"
    shows "x⇧^ω ⊑ y⇧^ω"
proof -
  have 1: "x ≤ y ⊔ L ∧ C y ≤ x ⊔ n(x) * top"
    using assms apx_def by auto
  have "n(x) * top ⊔ x * (x⇧^ω ⊔ n(x⇧^ω) * top) ≤ n(x) * top ⊔ x⇧^ω ⊔ n(x⇧^ω) * top"
    by (metis le_supI n_split_top sup.cobounded1 sup_assoc mult_assoc mult_left_dist_sup sup_right_isotone omega_unfold)
  also have "... ≤ x⇧^ω ⊔ n(x⇧^ω) * top"
    by (metis sup_commute sup_right_isotone mult_left_isotone n_below_n_omega sup_assoc sup_idem)
  finally have 2: "x⇧^⋆ * n(x) * top ≤ x⇧^ω ⊔ n(x⇧^ω) * top"
    using star_left_induct mult_assoc by auto
  have "C (y⇧^ω) = (C y)⇧^ω"
    by (simp add: C_omega_export)
  also have "... ≤ (x ⊔ n(x) * top)⇧^ω"
    using 1 omega_isotone by blast
  also have "... = (x⇧^⋆ * n(x) * top)⇧^ω ⊔ (x⇧^⋆ * n(x) * top)⇧^⋆ * x⇧^ω"
    by (simp add: omega_decompose mult_assoc)
  also have "... ≤ x⇧^⋆ * n(x) * top ⊔ (x⇧^⋆ * n(x) * top)⇧^⋆ * x⇧^ω"
    using mult_top_omega sup_left_isotone by blast
  also have "... = x⇧^⋆ * n(x) * top ⊔ (1 ⊔ x⇧^⋆ * n(x) * top * (x⇧^⋆ * n(x) * top)⇧^⋆) * x⇧^ω"
    by (simp add: star_left_unfold_equal)
  also have "... ≤ x⇧^ω ⊔ x⇧^⋆ * n(x) * top"
    by (smt sup_mono sup_least mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone order_refl top_greatest sup.cobounded2)
  also have "... ≤ x⇧^ω ⊔ n(x⇧^ω) * top"
    using 2 by simp
  finally have 3: "C (y⇧^ω) ≤ x⇧^ω ⊔ n(x⇧^ω) * top"
    .
  have "x⇧^ω ≤ (y ⊔ L)⇧^ω"
    using 1 omega_isotone by simp
  also have "... = (y⇧^⋆ * L)⇧^ω ⊔ (y⇧^⋆ * L)⇧^⋆ * y⇧^ω"
    by (simp add: omega_decompose)
  also have "... = y⇧^⋆ * L * (y⇧^⋆ * L)⇧^ω ⊔ (y⇧^⋆ * L)⇧^⋆ * y⇧^ω"
    using omega_unfold by auto
  also have "... ≤ y⇧^⋆ * L ⊔ (y⇧^⋆ * L)⇧^⋆ * y⇧^ω"
    by (metis sup_left_isotone n_L_below_L mult_assoc mult_right_isotone)
  also have "... = y⇧^⋆ * L ⊔ (1 ⊔ y⇧^⋆ * L * (y⇧^⋆ * L)⇧^⋆) * y⇧^ω"
    by (simp add: star_left_unfold_equal)
  also have "... ≤ y⇧^⋆ * L ⊔ y⇧^ω"
    by (simp add: mult_L_star_mult_below star_left_unfold_equal sup_commute)
  also have "... ≤ y⇧^⋆ * bot ⊔ L ⊔ y⇧^ω"
    using n_L_split_L sup_left_isotone by auto
  finally have "x⇧^ω ≤ y⇧^ω ⊔ L"
    by (simp add: star_bot_below_omega sup.absorb1 sup.left_commute sup_commute)
  thus "x⇧^ω ⊑ y⇧^ω"
    using 3 by (simp add: apx_def)
qed

lemma combined_apx_left_isotone:
  "x ⊑ y ⟹ n(x⇧^ω) * L ⊔ x⇧^⋆ * z ⊑ n(y⇧^ω) * L ⊔ y⇧^⋆ * z"
  by (simp add: mult_apx_isotone n_L_apx_isotone star.circ_apx_isotone sup_apx_isotone omega_apx_isotone)

lemma combined_apx_left_isotone_2:
  "x ⊑ y ⟹ (x⇧^ω ⊓ L) ⊔ x⇧^⋆ * z ⊑ (y⇧^ω ⊓ L) ⊔ y⇧^⋆ * z"
  by (metis sup_apx_isotone mult_apx_left_isotone omega_apx_isotone star.circ_apx_isotone meet_L_apx_isotone)

lemma combined_apx_right_isotone:
  "y ⊑ z ⟹ n(x⇧^ω) * L ⊔ x⇧^⋆ * y ⊑ n(x⇧^ω) * L ⊔ x⇧^⋆ * z"
  by (simp add: mult_apx_isotone sup_apx_left_isotone sup_commute)

lemma combined_apx_right_isotone_2:
  "y ⊑ z ⟹ (x⇧^ω ⊓ L) ⊔ x⇧^⋆ * y ⊑ (x⇧^ω ⊓ L) ⊔ x⇧^⋆ * z"
  by (simp add: mult_apx_right_isotone sup_apx_right_isotone)

lemma combined_apx_isotone:
  "x ⊑ y ⟹ w ⊑ z ⟹ n(x⇧^ω) * L ⊔ x⇧^⋆ * w ⊑ n(y⇧^ω) * L ⊔ y⇧^⋆ * z"
  by (simp add: mult_apx_isotone n_L_apx_isotone star.circ_apx_isotone sup_apx_isotone omega_apx_isotone)

lemma combined_apx_isotone_2:
  "x ⊑ y ⟹ w ⊑ z ⟹ (x⇧^ω ⊓ L) ⊔ x⇧^⋆ * w ⊑ (y⇧^ω ⊓ L) ⊔ y⇧^⋆ * z"
  by (meson combined_apx_left_isotone_2 combined_apx_right_isotone_2 apx.order.trans)

lemma n_split_nu_mu:
  "C (y⇧^ω ⊔ y⇧^⋆ * z) ≤ y⇧^⋆ * z ⊔ n(y⇧^ω ⊔ y⇧^⋆ * z) * top"
proof -
  have "C (y⇧^ω ⊔ y⇧^⋆ * z) ≤ C (y⇧^ω) ⊔ y⇧^⋆ * z"
    by (simp add: inf_sup_distrib1 le_supI1 sup_commute)
  also have "... ≤ y⇧^⋆ * bot ⊔ n(y⇧^ω) * top ⊔ y⇧^⋆ * z"
    using n_split_omega_sup_zero sup_left_isotone by blast
  also have "... ≤ y⇧^⋆ * z ⊔ n(y⇧^ω ⊔ y⇧^⋆ * z) * top"
    using le_supI1 mult_left_isotone mult_right_isotone n_left_upper_bound sup_right_isotone by force
  finally show ?thesis
    .
qed

lemma n_split_nu_mu_2:
  "C (y⇧^ω ⊔ y⇧^⋆ * z) ≤ y⇧^⋆ * z ⊔ ((y⇧^ω ⊔ y⇧^⋆ * z) ⊓ L) ⊔ n(y⇧^ω ⊔ y⇧^⋆ * z) * top"
proof -
  have "C (y⇧^ω ⊔ y⇧^⋆ * z) ≤ C (y⇧^ω) ⊔ y⇧^⋆ * z"
    using inf.sup_left_isotone sup_inf_distrib2 by auto
  also have "... ≤ y⇧^⋆ * bot ⊔ n(y⇧^ω) * top ⊔ y⇧^⋆ * z"
    using n_split_omega_sup_zero sup_left_isotone by blast
  also have "... ≤ y⇧^⋆ * z ⊔ n(y⇧^ω ⊔ y⇧^⋆ * z) * top"
    using le_supI1 mult_left_isotone mult_right_isotone n_left_upper_bound semiring.add_left_mono by auto
  finally show ?thesis
    using order_lesseq_imp semiring.add_right_mono sup.cobounded1 by blast
qed

lemma loop_exists:
  "C (ν (λx . y * x ⊔ z)) ≤ μ (λx . y * x ⊔ z) ⊔ n(ν (λx . y * x ⊔ z)) * top"
  using omega_loop_nu star_loop_mu n_split_nu_mu by auto

lemma loop_exists_2:
  "C (ν (λx . y * x ⊔ z)) ≤ μ (λx . y * x ⊔ z) ⊔ (ν (λx . y * x ⊔ z) ⊓ L) ⊔ n(ν (λx . y * x ⊔ z)) * top"
  by (simp add: omega_loop_nu star_loop_mu n_split_nu_mu_2)

lemma loop_apx_least_fixpoint:
  "apx.is_least_fixpoint (λx . y * x ⊔ z) (μ (λx . y * x ⊔ z) ⊔ n(ν (λx . y * x ⊔ z)) * L)"
proof -
  have "kappa_mu_nu_L (λx . y * x ⊔ z)"
    by (metis affine_apx_isotone loop_exists affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone nu_below_mu_nu_L_def nu_below_mu_nu_L_kappa_mu_nu_L)
  thus ?thesis
    using apx.least_fixpoint_char kappa_mu_nu_L_def by force
qed

lemma loop_apx_least_fixpoint_2:
  "apx.is_least_fixpoint (λx . y * x ⊔ z) (μ (λx . y * x ⊔ z) ⊔ (ν (λx . y * x ⊔ z) ⊓ L))"
proof -
  have "kappa_mu_nu (λx . y * x ⊔ z)"
    by (metis affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone loop_exists_2 nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu)
  thus ?thesis
    using apx.least_fixpoint_char kappa_mu_nu_def by force
qed

lemma loop_has_apx_least_fixpoint:
  "apx.has_least_fixpoint (λx . y * x ⊔ z)"
  using apx.least_fixpoint_char loop_apx_least_fixpoint by blast

lemma loop_semantics:
  "κ (λx . y * x ⊔ z) = μ (λx . y * x ⊔ z) ⊔ n(ν (λx . y * x ⊔ z)) * L"
  using apx.least_fixpoint_char loop_apx_least_fixpoint by force

lemma loop_semantics_2:
  "κ (λx . y * x ⊔ z) = μ (λx . y * x ⊔ z) ⊔ (ν (λx . y * x ⊔ z) ⊓ L)"
  using apx.least_fixpoint_char loop_apx_least_fixpoint_2 by force

text ‹AACP Theorem 8.15›

lemma loop_semantics_kappa_mu_nu:
  "κ (λx . y * x ⊔ z) = n(y⇧^ω) * L ⊔ y⇧^⋆ * z"
proof -
  have "κ (λx . y * x ⊔ z) = y⇧^⋆ * z ⊔ n(y⇧^ω ⊔ y⇧^⋆ * z) * L"
    using apx.least_fixpoint_char omega_loop_nu star_loop_mu loop_apx_least_fixpoint by auto
  thus ?thesis
    by (smt n_dist_omega_star sup_assoc mult_right_dist_sup sup_commute le_iff_sup n_L_decreasing)
qed

text ‹AACP Theorem 8.15›

lemma loop_semantics_kappa_mu_nu_2:
  "κ (λx . y * x ⊔ z) = (y⇧^ω ⊓ L) ⊔ y⇧^⋆ * z"
proof -
  have "κ (λx . y * x ⊔ z) = y⇧^⋆ * z ⊔ ((y⇧^ω ⊔ y⇧^⋆ * z) ⊓ L)"
    using apx.least_fixpoint_char omega_loop_nu star_loop_mu loop_apx_least_fixpoint_2 by auto
  thus ?thesis
    by (metis sup_absorb2 sup_ge2 sup_inf_distrib1 sup_monoid.add_commute)
qed

text ‹AACP Theorem 8.16›

lemma loop_semantics_apx_left_isotone:
  "w ⊑ y ⟹ κ (λx . w * x ⊔ z) ⊑ κ (λx . y * x ⊔ z)"
  by (metis loop_semantics_kappa_mu_nu_2 combined_apx_left_isotone_2)

text ‹AACP Theorem 8.16›

lemma loop_semantics_apx_right_isotone:
  "w ⊑ z ⟹ κ (λx . y * x ⊔ w) ⊑ κ (λx . y * x ⊔ z)"
  by (metis loop_semantics_kappa_mu_nu_2 combined_apx_right_isotone_2)

lemma loop_semantics_apx_isotone:
  "v ⊑ y ⟹ w ⊑ z ⟹ κ (λx . v * x ⊔ w) ⊑ κ (λx . y * x ⊔ z)"
  using apx_transitive_2 loop_semantics_apx_left_isotone loop_semantics_apx_right_isotone by blast

end

end

Theory N_Omega_Binary_Iterings

(* Title:      N-Omega Binary Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹N-Omega Binary Iterings›

theory N_Omega_Binary_Iterings

imports N_Omega_Algebras Binary_Iterings_Strict

begin

sublocale extended_binary_itering < left_zero_conway_semiring where circ = "(λx . x ⋆ 1)"
  apply unfold_locales
  using while_left_unfold apply force
  apply (metis mult_1_right while_one_mult_below while_slide)
  by (simp add: while_one_while while_sumstar_2)

class binary_itering_apx = bounded_binary_itering + n_algebra_apx
begin

lemma C_while_import:
  "C (x ⋆ z) = C (C x ⋆ z)"
proof -
  have 1: "C x * (x ⋆ z) ≤ C x ⋆ (C x * z)"
    using C_mult_propagate while_simulate by force
  have "C (x ⋆ z) = C z ⊔ C x * (x ⋆ z)"
    by (metis inf_sup_distrib1 n_L_T_meet_mult while_left_unfold)
  also have "... ≤ C x ⋆ z"
    using 1 by (metis C_decreasing sup_mono while_right_unfold)
  finally have "C (x ⋆ z) ≤ C (C x ⋆ z)"
    by simp
  thus ?thesis
    by (metis order.antisym inf.boundedI inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_commute while_absorb_2 while_increasing)
qed

lemma C_while_preserve:
  "C (x ⋆ z) = C (x ⋆ C z)"
proof -
  have "C x * (x ⋆ z) ≤ C x ⋆ (C x * z)"
    using C_mult_propagate while_simulate by auto
  also have "... ≤ x ⋆ (x * C z)"
    using C_decreasing n_L_T_meet_mult_propagate while_isotone by blast
  finally have 1: "C x * (x ⋆ z) ≤ x ⋆ (x * C z)"
    .
  have "C (x ⋆ z) = C z ⊔ C x * (x ⋆ z)"
    by (metis inf_sup_distrib1 n_L_T_meet_mult while_left_unfold)
  also have "... ≤ x ⋆ C z"
    using 1 by (meson order.trans le_supI while_increasing while_right_plus_below)
  finally have "C (x ⋆ z) ≤ C (x ⋆ C z)"
    by simp
  thus ?thesis
    by (meson order.antisym inf.boundedI inf.cobounded1 inf.coboundedI2 inf.eq_refl while_isotone)
qed

lemma C_while_import_preserve:
  "C (x ⋆ z) = C (C x ⋆ C z)"
  using C_while_import C_while_preserve by auto

lemma while_L_L:
  "L ⋆ L = L"
  by (metis n_L_top_L while_mult_star_exchange while_right_top)

lemma while_L_below_sup:
  "L ⋆ x ≤ x ⊔ L"
  by (metis while_left_unfold sup_right_isotone n_L_below_L)

lemma while_L_split:
  "x ⋆ L ≤ (x ⋆ y) ⊔ L"
proof -
  have "x ⋆ L ≤ (x ⋆ bot) ⊔ L"
    by (metis sup_commute sup_bot_left mult_1_right n_L_split_L while_right_unfold while_simulate_left_plus while_zero)
  thus ?thesis
    by (metis sup_commute sup_right_isotone order_trans while_right_isotone bot_least)
qed

lemma while_n_while_top_split:
  "x ⋆ (n(x ⋆ y) * top) ≤ (x ⋆ bot) ⊔ n(x ⋆ y) * top"
proof -
  have "x * n(x ⋆ y) * top ≤ x * bot ⊔ n(x * (x ⋆ y)) * top"
    by (simp add: n_n_top_split_n_top)
  also have "... ≤ n(x ⋆ y) * top ⊔ x * bot"
    by (metis sup_commute sup_right_isotone mult_left_isotone n_isotone while_left_plus_below)
  finally have "x ⋆ (n(x ⋆ y) * top) ≤ n(x ⋆ y) * top ⊔ (x ⋆ (x * bot))"
    by (metis mult_assoc mult_1_right while_simulate_left mult_left_zero while_left_top)
  also have "... ≤ (x ⋆ bot) ⊔ n(x ⋆ y) * top"
    using sup_left_isotone while_right_plus_below by auto
  finally show ?thesis
    .
qed

lemma circ_apx_right_isotone:
  assumes "x ⊑ y"
    shows "z ⋆ x ⊑ z ⋆ y"
proof -
  have 1: "x ≤ y ⊔ L ∧ C y ≤ x ⊔ n(x) * top"
    using assms apx_def by auto
  hence "z ⋆ x ≤ (z ⋆ y) ⊔ (z ⋆ L)"
    by (metis while_left_dist_sup while_right_isotone)
  hence 2: "z ⋆ x ≤ (z ⋆ y) ⊔ L"
    by (meson le_supI order_lesseq_imp sup.cobounded1 while_L_split)
  have "z ⋆ (n(z ⋆ x) * top) ≤ (z ⋆ bot) ⊔ n(z ⋆ x) * top"
    by (simp add: while_n_while_top_split)
  also have "... ≤ (z ⋆ x) ⊔ n(z ⋆ x) * top"
    using sup_left_isotone while_right_isotone by force
  finally have 3: "z ⋆ (n(x) * top) ≤ (z ⋆ x) ⊔ n(z ⋆ x) * top"
    by (metis mult_left_isotone n_isotone order_trans while_increasing while_right_isotone)
  have "C (z ⋆ y) ≤ z ⋆ C y"
    by (metis C_while_preserve inf.cobounded2)
  also have "... ≤ (z ⋆ x) ⊔ (z ⋆ (n(x) * top))"
    using 1 by (metis while_left_dist_sup while_right_isotone)
  also have "... ≤ (z ⋆ x) ⊔ n(z ⋆ x) * top"
    using 3 by simp
  finally show ?thesis
    using 2 apx_def by auto
qed

end

class extended_binary_itering_apx = binary_itering_apx + bounded_extended_binary_itering +
  assumes n_below_while_zero: "n(x) ≤ n(x ⋆ bot)"
begin

lemma circ_apx_right_isotone:
  assumes "x ⊑ y"
    shows "x ⋆ z ⊑ y ⋆ z"
proof -
  have 1: "x ≤ y ⊔ L ∧ C y ≤ x ⊔ n(x) * top"
    using assms apx_def by auto
  hence "x ⋆ z ≤ ((y ⋆ 1) * L) ⋆ (y ⋆ z)"
    by (metis while_left_isotone while_sumstar_3)
  also have "... ≤ (y ⋆ z) ⊔ (y ⋆ 1) * L"
    by (metis while_productstar sup_right_isotone mult_right_isotone n_L_below_L while_slide)
  also have "... ≤ (y ⋆ z) ⊔ L"
    by (meson order.trans le_supI sup.cobounded1 while_L_split while_one_mult_below)
  finally have 2: "x ⋆ z ≤ (y ⋆ z) ⊔ L"
    .
  have "C (y ⋆ z) ≤ C y ⋆ z"
    by (metis C_while_import inf.sup_right_divisibility)
  also have "... ≤ ((x ⋆ 1) * n(x) * top) ⋆ (x ⋆ z)"
    using 1 by (metis while_left_isotone mult_assoc while_sumstar_3)
  also have "... ≤ (x ⋆ z) ⊔ (x ⋆ 1) * n(x) * top"
    by (metis while_productstar sup_left_top sup_right_isotone mult_assoc mult_left_sub_dist_sup_right while_slide)
  also have "... ≤ (x ⋆ z) ⊔ (x ⋆ (n(x) * top))"
    using sup_right_isotone while_one_mult_below mult_assoc by auto
  also have "... ≤ (x ⋆ z) ⊔ (x ⋆ (n(x ⋆ z) * top))"
    by (metis n_below_while_zero bot_least while_right_isotone n_isotone mult_left_isotone sup_right_isotone order_trans)
  also have "... ≤ (x ⋆ z) ⊔ n(x ⋆ z) * top"
    by (metis sup_assoc sup_right_isotone while_n_while_top_split sup_bot_right while_left_dist_sup)
  finally show ?thesis
    using 2 apx_def by auto
qed

(*
lemma while_top: "top ⋆ x = L ⊔ top * x" oops
lemma while_one_top: "1 ⋆ x = L ⊔ x" oops
lemma while_unfold_below_1: "x = y * x ⟹ x ≤ y ⋆ 1" oops

lemma while_square_1: "x ⋆ 1 = (x * x) ⋆ (x ⊔ 1)" oops
lemma while_absorb_below_one: "y * x ≤ x ⟹ y ⋆ x ≤ 1 ⋆ x" oops
lemma while_mult_L: "(x * L) ⋆ z = z ⊔ x * L" oops
lemma tarski_top_omega_below_2: "x * L ≤ (x * L) ⋆ bot" oops
lemma tarski_top_omega_2: "x * L = (x * L) ⋆ bot" oops
lemma while_separate_right_plus: "y * x ≤ x * (x ⋆ (1 ⊔ y)) ⊔ 1 ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)" oops
lemma "y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
lemma "y * x ≤ (1 ⊔ x) * (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
*)

end

class n_omega_algebra_binary = n_omega_algebra + while +
  assumes while_def: "x ⋆ y = n(x⇧^ω) * L ⊔ x⇧^⋆ * y"
begin

lemma while_omega_inf_L_star:
  "x ⋆ y = (x⇧^ω ⊓ L) ⊔ x⇧^⋆ * y"
  by (metis loop_semantics_kappa_mu_nu loop_semantics_kappa_mu_nu_2 while_def)

lemma while_one_mult_while_below_1:
  "(y ⋆ 1) * (y ⋆ v) ≤ y ⋆ v"
proof -
  have "(y ⋆ 1) * (y ⋆ v) ≤ y ⋆ (y ⋆ v)"
    by (smt sup_left_isotone mult_assoc mult_right_dist_sup mult_right_isotone n_L_below_L while_def mult_left_one)
  also have "... = n(y⇧^ω) * L ⊔ y⇧^⋆ * n(y⇧^ω) * L ⊔ y⇧^⋆ * y⇧^⋆ * v"
    by (simp add: mult_left_dist_sup sup_assoc while_def mult_assoc)
  also have "... = n(y⇧^ω) * L ⊔ (y⇧^⋆ * y⇧^⋆ * bot ⊔ y⇧^⋆ * n(y⇧^ω) * L) ⊔ y⇧^⋆ * y⇧^⋆ * v"
    by (metis mult_left_dist_sup star.circ_transitive_equal sup_bot_left mult_assoc)
  also have "... = n(y⇧^ω) * L ⊔ (y⇧^⋆ * y⇧^⋆ * bot ⊔ n(y⇧^⋆ * y⇧^ω) * L) ⊔ y⇧^⋆ * y⇧^⋆ * v"
    by (simp add: n_mult_omega_L_star_zero)
  also have "... = n(y⇧^ω) * L ⊔ n(y⇧^⋆ * y⇧^ω) * L ⊔ y⇧^⋆ * y⇧^⋆ * v"
    by (smt (z3) mult_left_dist_sup sup.left_commute sup_bot_left sup_commute)
  finally show ?thesis
    by (simp add: star.circ_transitive_equal star_mult_omega while_def)
qed

lemma star_below_while:
  "x⇧^⋆ * y ≤ x ⋆ y"
  by (simp add: while_def)

subclass bounded_binary_itering
proof unfold_locales
  fix x y z
  have "z ⊔ x * ((y * x) ⋆ (y * z)) = x * (y * x)⇧^⋆ * y * z ⊔ x * n((y * x)⇧^ω) * L ⊔ z"
    using mult_left_dist_sup sup_commute while_def mult_assoc by auto
  also have "... = x * (y * x)⇧^⋆ * y * z ⊔ n(x * (y * x)⇧^ω) * L ⊔ z"
    by (metis mult_assoc mult_right_isotone bot_least n_mult_omega_L_star_zero sup_relative_same_increasing)
  also have "... = (x * y)⇧^⋆ * z ⊔ n(x * (y * x)⇧^ω) * L"
    by (smt sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint star_slide)
  also have "... = (x * y) ⋆ z"
    by (simp add: omega_slide sup_monoid.add_commute while_def)
  finally show "(x * y) ⋆ z = z ⊔ x * ((y * x) ⋆ (y * z))"
    by simp
next
  fix x y z
  have "(x ⋆ y) ⋆ (x ⋆ z) = n((n(x⇧^ω) * L ⊔ x⇧^⋆ * y)⇧^ω) * L ⊔ (n(x⇧^ω) * L ⊔ x⇧^⋆ * y)⇧^⋆ * (x ⋆ z)"
    by (simp add: while_def)
  also have "... = n((x⇧^⋆ * y)⇧^ω ⊔ (x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L) * L ⊔ ((x⇧^⋆ * y)⇧^⋆ ⊔ (x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L) * (x ⋆ z)"
    using mult_L_sup_omega mult_L_sup_star by force
  also have "... = n((x⇧^⋆ * y)⇧^ω) * L ⊔ n((x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L) * L ⊔ (x⇧^⋆ * y)⇧^⋆ * (x ⋆ z) ⊔ (x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L * (x ⋆ z)"
    by (simp add: mult_right_dist_sup n_dist_omega_star sup_assoc mult_assoc)
  also have "... = n((x⇧^⋆ * y)⇧^ω) * L ⊔ n((x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L) * L ⊔ (x⇧^⋆ * y)⇧^⋆ * bot ⊔ (x⇧^⋆ * y)⇧^⋆ * (x ⋆ z) ⊔ (x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L * (x ⋆ z)"
    by (smt sup_assoc sup_bot_left mult_left_dist_sup)
  also have "... = n((x⇧^⋆ * y)⇧^ω) * L ⊔ ((x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L * (x ⋆ z) ⊔ (x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L ⊔ (x⇧^⋆ * y)⇧^⋆ * (x ⋆ z))"
    by (smt n_n_L_split_n_n_L_L sup_commute sup_assoc)
  also have "... = n((x⇧^⋆ * y)⇧^ω) * L ⊔ ((x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L ⊔ (x⇧^⋆ * y)⇧^⋆ * (x ⋆ z))"
    by (smt mult_L_omega omega_sub_vector le_iff_sup)
  also have "... = n((x⇧^⋆ * y)⇧^ω) * L ⊔ (x⇧^⋆ * y)⇧^⋆ * (x ⋆ z)"
    using mult_left_sub_dist_sup_left sup_absorb2 while_def mult_assoc by auto
  also have "... = (x⇧^⋆ * y)⇧^⋆ * x⇧^⋆ * z ⊔ (x⇧^⋆ * y)⇧^⋆ * n(x⇧^ω) * L ⊔ n((x⇧^⋆ * y)⇧^ω) * L"
    by (simp add: mult_left_dist_sup sup_commute while_def mult_assoc)
  also have "... = (x⇧^⋆ * y)⇧^⋆ * x⇧^⋆ * z ⊔ n((x⇧^⋆ * y)⇧^⋆ * x⇧^ω) * L ⊔ n((x⇧^⋆ * y)⇧^ω) * L"
    by (metis sup_bot_right mult_left_dist_sup sup_assoc n_mult_omega_L_star_zero)
  also have "... = (x ⊔ y) ⋆ z"
    using n_dist_omega_star omega_decompose semiring.combine_common_factor star.circ_sup_9 sup_commute while_def by force
  finally show "(x ⊔ y) ⋆ z = (x ⋆ y) ⋆ (x ⋆ z)"
    by simp
next
  fix x y z
  show "x ⋆ (y ⊔ z) = (x ⋆ y) ⊔ (x ⋆ z)"
    using semiring.distrib_left sup_assoc sup_commute while_def by force
next
  fix x y z
  show "(x ⋆ y) * z ≤ x ⋆ (y * z)"
    by (smt sup_left_isotone mult_assoc mult_right_dist_sup mult_right_isotone n_L_below_L while_def)
next
  fix v w x y z
  show "x * z ≤ z * (y ⋆ 1) ⊔ w ⟶ x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ (w * (y ⋆ v)))"
  proof
    assume 1: "x * z ≤ z * (y ⋆ 1) ⊔ w"
    have "z * v ⊔ x * (z * (y ⋆ v) ⊔ x⇧^⋆ * (w * (y ⋆ v))) ≤ z * v ⊔ x * z * (y ⋆ v) ⊔ x⇧^⋆ * (w * (y ⋆ v))"
      by (metis sup_assoc sup_right_isotone mult_assoc mult_left_dist_sup mult_left_isotone star.left_plus_below_circ)
    also have "... ≤ z * v ⊔ z * (y ⋆ 1) * (y ⋆ v) ⊔ w * (y ⋆ v) ⊔ x⇧^⋆ * (w * (y ⋆ v))"
      using 1 by (metis sup_assoc sup_left_isotone sup_right_isotone mult_left_isotone mult_right_dist_sup)
    also have "... ≤ z * v ⊔ z * (y ⋆ v) ⊔ x⇧^⋆ * (w * (y ⋆ v))"
      by (smt (verit, ccfv_threshold) sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup star.circ_loop_fixpoint while_one_mult_while_below_1 le_supE le_supI)
    also have "... = z * (y ⋆ v) ⊔ x⇧^⋆ * (w * (y ⋆ v))"
      by (metis le_iff_sup le_supE mult_right_isotone star.circ_loop_fixpoint star_below_while)
    finally have "x⇧^⋆ * z * v ≤ z * (y ⋆ v) ⊔ x⇧^⋆ * (w * (y ⋆ v))"
      using star_left_induct mult_assoc by auto
    thus "x ⋆ (z * v) ≤ z * (y ⋆ v) ⊔ (x ⋆ (w * (y ⋆ v)))"
      by (smt sup_assoc sup_commute sup_right_isotone mult_assoc while_def)
  qed
next
  fix v w x y z
  show "z * x ≤ y * (y ⋆ z) ⊔ w ⟶ z * (x ⋆ v) ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
  proof
    assume "z * x ≤ y * (y ⋆ z) ⊔ w"
    hence 1: "z * x ≤ y * y⇧^⋆ * z ⊔ (y * n(y⇧^ω) * L ⊔ w)"
      by (simp add: mult_left_dist_sup sup.left_commute sup_commute while_def mult_assoc)
    hence "z * x⇧^⋆ ≤ y⇧^⋆ * (z ⊔ (y * n(y⇧^ω) * L ⊔ w) * x⇧^⋆)"
      by (simp add: star_circ_simulate_right_plus)
    also have "... = y⇧^⋆ * z ⊔ y⇧^⋆ * y * n(y⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
      by (simp add: L_mult_star semiring.distrib_left semiring.distrib_right sup_left_commute sup_monoid.add_commute mult_assoc)
    also have "... = y⇧^⋆ * z ⊔ n(y⇧^⋆ * y * y⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
      by (metis sup_relative_same_increasing mult_isotone n_mult_omega_L_star_zero star.left_plus_below_circ star.right_plus_circ bot_least)
    also have "... = n(y⇧^ω) * L ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * x⇧^⋆"
      using omega_unfold star_mult_omega sup_commute mult_assoc by force
    finally have "z * x⇧^⋆ * v ≤ n(y⇧^ω) * L * v ⊔ y⇧^⋆ * z * v ⊔ y⇧^⋆ * w * x⇧^⋆ * v"
      by (smt le_iff_sup mult_right_dist_sup)
    also have "... ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ * (z * v ⊔ w * x⇧^⋆ * v)"
      by (metis n_L_below_L mult_assoc mult_right_isotone sup_left_isotone mult_left_dist_sup sup_assoc)
    also have "... ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ * (z * v ⊔ w * (x ⋆ v))"
      using mult_right_isotone semiring.add_left_mono mult_assoc star_below_while by auto
    finally have 2: "z * x⇧^⋆ * v ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
      by (simp add: while_def)
    have 3: "y⇧^⋆ * y * y⇧^⋆ * bot ≤ y⇧^⋆ * w * x⇧^ω"
      by (metis sup_commute sup_bot_left mult_assoc mult_left_sub_dist_sup_left star.circ_loop_fixpoint star.circ_transitive_equal)
    have "z * x⇧^ω ≤ y * y⇧^⋆ * z * x⇧^ω ⊔ (y * n(y⇧^ω) * L ⊔ w) * x⇧^ω"
      using 1 by (metis mult_assoc mult_left_isotone mult_right_dist_sup omega_unfold)
    hence "z * x⇧^ω ≤ y⇧^ω ⊔ y⇧^⋆ * y * n(y⇧^ω) * L * x⇧^ω ⊔ y⇧^⋆ * w * x⇧^ω"
      by (smt sup_assoc sup_commute left_plus_omega mult_assoc mult_left_dist_sup mult_right_dist_sup omega_induct star.left_plus_circ)
    also have "... ≤ y⇧^ω ⊔ y⇧^⋆ * y * n(y⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^ω"
      by (metis sup_left_isotone sup_right_isotone mult_assoc mult_right_isotone n_L_below_L)
    also have "... = y⇧^ω ⊔ n(y⇧^⋆ * y * y⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^ω"
      using 3 by (smt sup_assoc sup_commute sup_relative_same_increasing n_mult_omega_L_star_zero)
    also have "... = y⇧^ω ⊔ y⇧^⋆ * w * x⇧^ω"
      by (metis mult_assoc omega_unfold star_mult_omega sup_commute le_iff_sup n_L_decreasing)
    finally have "n(z * x⇧^ω) * L ≤ n(y⇧^ω) * L ⊔ n(y⇧^⋆ * w * x⇧^ω) * L"
      by (metis mult_assoc mult_left_isotone mult_right_dist_sup n_dist_omega_star n_isotone)
    also have "... ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ * (w * (n(x⇧^ω) * L ⊔ x⇧^⋆ * bot))"
      by (smt sup_commute sup_right_isotone mult_assoc mult_left_dist_sup n_mult_omega_L_below_zero)
    also have "... ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ * (w * (n(x⇧^ω) * L ⊔ x⇧^⋆ * v))"
      by (metis sup_right_isotone mult_right_isotone bot_least)
    also have "... ≤ n(y⇧^ω) * L ⊔ y⇧^⋆ * (z * v ⊔ w * (n(x⇧^ω) * L ⊔ x⇧^⋆ * v))"
      using mult_left_sub_dist_sup_right sup_right_isotone by auto
    finally have 4: "n(z * x⇧^ω) * L ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
      using while_def by auto
    have "z * (x ⋆ v) = z * n(x⇧^ω) * L ⊔ z * x⇧^⋆ * v"
      by (simp add: mult_left_dist_sup while_def mult_assoc)
    also have "... = n(z * x⇧^ω) * L ⊔ z * x⇧^⋆ * v"
      by (metis sup_commute sup_relative_same_increasing mult_right_isotone n_mult_omega_L_star_zero bot_least)
    finally show "z * (x ⋆ v) ≤ y ⋆ (z * v ⊔ w * (x ⋆ v))"
      using 2 4 by simp
  qed
qed

lemma while_top:
  "top ⋆ x = L ⊔ top * x"
  by (metis n_top_L star.circ_top star_omega_top while_def)

lemma while_one_top:
  "1 ⋆ x = L ⊔ x"
  by (smt mult_left_one n_top_L omega_one star_one while_def)

lemma while_finite_associative:
  "x⇧^ω = bot ⟹ (x ⋆ y) * z = x ⋆ (y * z)"
  by (metis sup_bot_left mult_assoc n_zero_L_zero while_def)

lemma while_while_one:
  "y ⋆ (x ⋆ 1) = n(y⇧^ω) * L ⊔ y⇧^⋆ * n(x⇧^ω) * L ⊔ y⇧^⋆ * x⇧^⋆"
  by (simp add: mult_left_dist_sup sup_assoc while_def mult_assoc)

text ‹AACP Theorem 8.17›

subclass bounded_extended_binary_itering
proof unfold_locales
  fix w x y z
  have "w * (x ⋆ y * z) = n(w * n(x⇧^ω) * L) * L ⊔ w * x⇧^⋆ * y * z"
    by (smt sup_assoc sup_commute sup_bot_left mult_assoc mult_left_dist_sup n_n_L_split_n_n_L_L while_def)
  also have "... ≤ n((w * n(x⇧^ω) * L)⇧^ω) * L ⊔ w * x⇧^⋆ * y * z"
    by (simp add: mult_L_omega)
  also have "... ≤ n((w * (x ⋆ y))⇧^ω) * L ⊔ w * x⇧^⋆ * y * z"
    by (smt sup_left_isotone sup_ge1 mult_assoc mult_left_isotone mult_right_isotone n_isotone omega_isotone while_def)
  also have "... ≤ n((w * (x ⋆ y))⇧^ω) * L ⊔ w * (x ⋆ y) * z"
    by (metis star_below_while mult_assoc mult_left_isotone mult_right_isotone sup_right_isotone)
  also have "... ≤ n((w * (x ⋆ y))⇧^ω) * L ⊔ (w * (x ⋆ y))⇧^⋆ * (w * (x ⋆ y) * z)"
    using sup.boundedI sup.cobounded1 while_def while_increasing by auto
  finally show "w * (x ⋆ y * z) ≤ (w * (x ⋆ y)) ⋆ (w * (x ⋆ y) * z)"
    using while_def by auto
qed

subclass extended_binary_itering_apx
  apply unfold_locales
  by (metis n_below_n_omega n_left_upper_bound n_n_L order_trans while_def)

lemma while_simulate_4_plus:
  assumes "y * x ≤ x * (x ⋆ (1 ⊔ y))"
    shows "y * x * x⇧^⋆ ≤ x * (x ⋆ (1 ⊔ y))"
proof -
  have "x * (x ⋆ (1 ⊔ y)) = x * n(x⇧^ω) * L ⊔ x * x⇧^⋆ * (1 ⊔ y)"
    by (simp add: mult_left_dist_sup while_def mult_assoc)
  also have "... = n(x * x⇧^ω) * L ⊔ x * x⇧^⋆ * (1 ⊔ y)"
    by (smt n_mult_omega_L_star_zero sup_relative_same_increasing sup_commute sup_bot_right mult_left_sub_dist_sup_right)
  finally have 1: "x * (x ⋆ (1 ⊔ y)) = n(x⇧^ω) * L ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y"
    using mult_left_dist_sup omega_unfold sup_assoc by force
  hence "x * x⇧^⋆ * y * x ≤ x * x⇧^⋆ * n(x⇧^ω) * L ⊔ x * x⇧^⋆ * x⇧^⋆ * x ⊔ x * x⇧^⋆ * x * x⇧^⋆ * y"
    by (metis assms mult_assoc mult_right_isotone mult_left_dist_sup star_plus)
  also have "... = n(x * x⇧^⋆ * x⇧^ω) * L ⊔ x * x⇧^⋆ * x⇧^⋆ * x ⊔ x * x⇧^⋆ * x * x⇧^⋆ * y"
    by (smt (z3) sup_commute n_mult_omega_L_star omega_unfold semiring.distrib_left star_plus mult_assoc)
  also have "... = n(x⇧^ω) * L ⊔ x * x⇧^⋆ * x ⊔ x * x * x⇧^⋆ * y"
    using omega_unfold star.circ_plus_same star.circ_transitive_equal star_mult_omega mult_assoc by auto
  also have "... ≤ n(x⇧^ω) * L ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y"
    by (smt sup_assoc sup_ge2 le_iff_sup mult_assoc mult_right_dist_sup star.circ_increasing star.circ_plus_same star.circ_transitive_equal)
  finally have 2: "x * x⇧^⋆ * y * x ≤ n(x⇧^ω) * L ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y"
    .
  have "(n(x⇧^ω) * L ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y) * x ≤ n(x⇧^ω) * L ⊔ x * x⇧^⋆ * x ⊔ x * x⇧^⋆ * y * x"
    by (metis mult_right_dist_sup n_L_below_L mult_assoc mult_right_isotone sup_left_isotone)
  also have "... ≤ n(x⇧^ω) * L ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y * x"
    by (smt sup_commute sup_left_isotone mult_assoc mult_right_isotone star.left_plus_below_circ star_plus)
  also have "... ≤ n(x⇧^ω) * L ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y"
    using 2 by simp
  finally show ?thesis
    using 1 assms star_right_induct by force
qed

lemma while_simulate_4_omega:
  assumes "y * x ≤ x * (x ⋆ (1 ⊔ y))"
    shows "y * x⇧^ω ≤ x⇧^ω"
proof -
  have "x * (x ⋆ (1 ⊔ y)) = x * n(x⇧^ω) * L ⊔ x * x⇧^⋆ * (1 ⊔ y)"
    using mult_left_dist_sup while_def mult_assoc by auto
  also have "... = n(x * x⇧^ω) * L ⊔ x * x⇧^⋆ * (1 ⊔ y)"
    by (smt (z3) mult_1_right mult_left_sub_dist_sup_left n_mult_omega_L_star sup_commute sup_relative_same_increasing)
  finally have "x * (x ⋆ (1 ⊔ y)) = n(x⇧^ω) * L ⊔ x * x⇧^⋆ ⊔ x * x⇧^⋆ * y"
    using mult_left_dist_sup omega_unfold sup_assoc by force
  hence "y * x⇧^ω ≤ n(x⇧^ω) * L * x⇧^ω ⊔ x * x⇧^⋆ * x⇧^ω ⊔ x * x⇧^⋆ * y * x⇧^ω"
    by (smt assms le_iff_sup mult_assoc mult_right_dist_sup omega_unfold)
  also have "... ≤ x * x⇧^⋆ * (y * x⇧^ω) ⊔ x⇧^ω"
    by (metis sup_left_isotone mult_L_omega omega_sub_vector mult_assoc omega_unfold star_mult_omega n_L_decreasing le_iff_sup sup_commute)
  finally have "y * x⇧^ω ≤ (x * x⇧^⋆)⇧^ω ⊔ (x * x⇧^⋆)⇧^⋆ * x⇧^ω"
    by (simp add: omega_induct sup_monoid.add_commute)
  thus ?thesis
    by (metis sup_idem left_plus_omega star_mult_omega)
qed

lemma while_square_1:
  "x ⋆ 1 = (x * x) ⋆ (x ⊔ 1)"
  by (metis mult_1_right omega_square star_square_2 while_def)

lemma while_absorb_below_one:
  "y * x ≤ x ⟹ y ⋆ x ≤ 1 ⋆ x"
  by (metis star_left_induct_mult sup_mono n_galois n_sub_nL while_def while_one_top)

lemma while_mult_L:
  "(x * L) ⋆ z = z ⊔ x * L"
  by (metis sup_bot_right mult_left_zero while_denest_5 while_one_top while_productstar while_sumstar)

lemma tarski_top_omega_below_2:
  "x * L ≤ (x * L) ⋆ bot"
  by (simp add: while_mult_L)

lemma tarski_top_omega_2:
  "x * L = (x * L) ⋆ bot"
  by (simp add: while_mult_L)

(*
lemma while_sub_mult_one: "x * (1 ⋆ y) ≤ 1 ⋆ x" nitpick [expect=genuine,card=3] oops
lemma while_unfold_below: "x = z ⊔ y * x ⟶ x ≤ y ⋆ z" nitpick [expect=genuine,card=2] oops
lemma while_loop_is_greatest_postfixpoint: "is_greatest_postfixpoint (λx . y * x ⊔ z) (y ⋆ z)" nitpick [expect=genuine,card=2] oops
lemma while_loop_is_greatest_fixpoint: "is_greatest_fixpoint (λx . y * x ⊔ z) (y ⋆ z)" nitpick [expect=genuine,card=2] oops
lemma while_denest_3: "(x ⋆ w) ⋆ x⇧^ω = (x ⋆ w)⇧^ω" nitpick [expect=genuine,card=2] oops
lemma while_mult_top: "(x * top) ⋆ z = z ⊔ x * top" nitpick [expect=genuine,card=2] oops
lemma tarski_below_top_omega: "x ≤ (x * L)⇧^ω" nitpick [expect=genuine,card=2] oops
lemma tarski_mult_omega_omega: "(x * y⇧^ω)⇧^ω = x * y⇧^ω" nitpick [expect=genuine,card=3] oops
lemma tarski_below_top_omega_2: "x ≤ (x * L) ⋆ bot" nitpick [expect=genuine,card=2] oops
lemma "1 = (x * bot) ⋆ 1" nitpick [expect=genuine,card=3] oops
lemma tarski: "x = bot ∨ top * x * top = top" nitpick [expect=genuine,card=3] oops
lemma "(x ⊔ y) ⋆ z = ((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z)" nitpick [expect=genuine,card=2] oops
lemma while_top_2: "top ⋆ z = top * z" nitpick [expect=genuine,card=2] oops
lemma while_mult_top_2: "(x * top) ⋆ z = z ⊔ x * top * z" nitpick [expect=genuine,card=2] oops
lemma while_one_mult: "(x ⋆ 1) * x = x ⋆ x" nitpick [expect=genuine,card=4] oops
lemma "(x ⋆ 1) * y = x ⋆ y" nitpick [expect=genuine,card=2] oops
lemma while_associative: "(x ⋆ y) * z = x ⋆ (y * z)" nitpick [expect=genuine,card=2] oops
lemma while_back_loop_is_fixpoint: "is_fixpoint (λx . x * y ⊔ z) (z * (y ⋆ 1))" nitpick [expect=genuine,card=4] oops
lemma "1 ⊔ x * bot = x ⋆ 1" nitpick [expect=genuine,card=3] oops
lemma "x = x * (x ⋆ 1)" nitpick [expect=genuine,card=3] oops
lemma "x * (x ⋆ 1) = x ⋆ 1" nitpick [expect=genuine,card=2] oops
lemma "x ⋆ 1 = x ⋆ (1 ⋆ 1)" nitpick [expect=genuine,card=3] oops
lemma "(x ⊔ y) ⋆ 1 = (x ⋆ (y ⋆ 1)) ⋆ 1" nitpick [expect=genuine,card=3] oops
lemma "z ⊔ y * x = x ⟹ y ⋆ z ≤ x" nitpick [expect=genuine,card=2] oops
lemma "y * x = x ⟹ y ⋆ x ≤ x" nitpick [expect=genuine,card=2] oops
lemma "z ⊔ x * y = x ⟹ z * (y ⋆ 1) ≤ x" nitpick [expect=genuine,card=3] oops
lemma "x * y = x ⟹ x * (y ⋆ 1) ≤ x" nitpick [expect=genuine,card=3] oops
lemma "x * z = z * y ⟹ x ⋆ z ≤ z * (y ⋆ 1)" nitpick [expect=genuine,card=2] oops

lemma while_unfold_below_1: "x = y * x ⟹ x ≤ y ⋆ 1" nitpick [expect=genuine,card=3] oops
lemma "x⇧^ω ≤ x⇧^ω * x⇧^ω" oops
lemma tarski_omega_idempotent: "x⇧^ω⇧^ω = x⇧^ω" oops
*)

end

class n_omega_algebra_binary_strict = n_omega_algebra_binary + circ +
  assumes L_left_zero: "L * x = L"
  assumes circ_def: "x⇧^∘ = n(x⇧^ω) * L ⊔ x⇧^⋆"
begin

subclass strict_binary_itering
  apply unfold_locales
  apply (metis while_def mult_assoc L_left_zero mult_right_dist_sup)
  by (metis circ_def while_def mult_1_right)

end

end

Theory N_Relation_Algebras

(* Title:      N-Relation-Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹N-Relation-Algebras›

theory N_Relation_Algebras

imports Stone_Relation_Algebras.Relation_Algebras N_Omega_Algebras

begin

context bounded_distrib_allegory
begin

subclass lattice_ordered_pre_left_semiring ..

end

text ‹Theorem 37›

sublocale relation_algebra < n_algebra where sup = sup and bot = bot and top = top and inf = inf and n = N and L = top
  apply unfold_locales
  using N_comp_top comp_inf.semiring.distrib_left inf.sup_monoid.add_commute inf_vector_comp apply simp
  apply (metis N_comp compl_sup double_compl mult_assoc mult_right_dist_sup top_mult_top N_comp_N)
  apply (metis brouwer.p_antitone inf.sup_monoid.add_commute inf.sup_right_isotone mult_left_isotone p_antitone_sup)
  apply simp
  using N_vector_top apply force
  apply simp
  apply (simp add: brouwer.p_antitone_iff top_right_mult_increasing)
  apply simp
  apply (metis N_comp_top conv_complement_sub double_compl le_supI2 le_iff_sup mult_assoc mult_left_isotone schroeder_3)
  by simp

sublocale relation_algebra < n_algebra_apx where sup = sup and bot = bot and top = top and inf = inf and n = N and L = top and apx = greater_eq
  apply unfold_locales
  using n_less_eq_char by force

no_notation
  inverse_divide (infixl "'/" 70)

notation
  divide (infixl "'/" 70)

class left_residuated_relation_algebra = relation_algebra + inverse +
  assumes lres_def: "x / y = -(-x * y⇧^T)"
begin

text ‹Theorem 32.1›

subclass residuated_pre_left_semiring
  apply unfold_locales
  by (metis compl_le_swap1 lres_def schroeder_4)

end

context left_residuated_relation_algebra
begin

text ‹Theorem 32.3›

lemma lres_mult_lres_lres:
  "x / (z * y) = (x / y) / z"
  by (metis conv_dist_comp double_compl lres_def mult_assoc)

text ‹Theorem 32.5›

lemma lres_dist_inf:
  "(x ⊓ y) / z = (x / z) ⊓ (y / z)"
  by (metis compl_inf compl_sup lres_def mult_right_dist_sup)

text ‹Theorem 32.6›

lemma lres_add_export_vector:
  assumes "vector x"
    shows "(x ⊔ y) / z = x ⊔ (y / z)"
proof -
  have "(x ⊔ y) / z = -((-x ⊓ -y) * z⇧^T)"
    by (simp add: lres_def)
  also have "... = -(-x ⊓ (-y * z⇧^T))"
    using assms vector_complement_closed vector_inf_comp by auto
  also have "... = x ⊔ (y / z)"
    by (simp add: lres_def)
  finally show ?thesis
    .
qed

text ‹Theorem 32.7›

lemma lres_top_vector:
  "vector (x / top)"
  using equivalence_top_closed lres_def vector_complement_closed vector_mult_closed vector_top_closed by auto

text ‹Theorem 32.10›

lemma lres_top_export_inf_mult:
  "((x / top) ⊓ y) * z = (x / top) ⊓ (y * z)"
  by (simp add: vector_inf_comp lres_top_vector)

lemma N_lres:
  "N(x) = x / top ⊓ 1"
  using lres_def by auto

end

class complete_relation_algebra = relation_algebra + complete_lattice
begin

definition mu :: "('a ⇒ 'a) ⇒ 'a" where "mu f ≡ Inf { y . f y ≤ y }"
definition nu :: "('a ⇒ 'a) ⇒ 'a" where "nu f ≡ Sup { y . y ≤ f y }"

lemma mu_lower_bound:
  "f x ≤ x ⟹ mu f ≤ x"
  by (auto simp add: mu_def intro: Inf_lower)

lemma mu_greatest_lower_bound:
  "(∀y . f y ≤ y ⟶ x ≤ y) ⟹ x ≤ mu f"
  using lfp_def lfp_greatest mu_def by auto

lemma mu_unfold_1:
  "isotone f ⟹ f (mu f) ≤ mu f"
  by (metis mu_greatest_lower_bound order_trans mu_lower_bound isotone_def)

lemma mu_unfold_2:
  "isotone f ⟹ mu f ≤ f (mu f)"
  by (simp add: mu_lower_bound mu_unfold_1 ord.isotone_def)

lemma mu_unfold:
  "isotone f ⟹ mu f = f (mu f)"
  by (simp add: order.antisym mu_unfold_1 mu_unfold_2)

lemma mu_const:
  "mu (λx . y) = y"
  by (simp add: isotone_def mu_unfold)

lemma mu_lpfp:
  "isotone f ⟹ is_least_prefixpoint f (mu f)"
  by (simp add: is_least_prefixpoint_def mu_lower_bound mu_unfold_1)
  
lemma mu_lfp:
  "isotone f ⟹ is_least_fixpoint f (mu f)"
  by (metis is_least_fixpoint_def mu_lower_bound mu_unfold order_refl)

lemma mu_pmu:
  "isotone f ⟹ pμ f = mu f"
  using least_prefixpoint_same mu_lpfp by force
  
lemma mu_mu:
  "isotone f ⟹ μ f = mu f"
  using least_fixpoint_same mu_lfp by fastforce
  
end

class omega_relation_algebra = relation_algebra + star + omega +
  assumes ra_star_left_unfold : "1 ⊔ y * y⇧^⋆ ≤ y⇧^⋆"
  assumes ra_star_left_induct : "z ⊔ y * x ≤ x ⟶ y⇧^⋆ * z ≤ x"
  assumes ra_star_right_induct: "z ⊔ x * y ≤ x ⟶ z * y⇧^⋆ ≤ x"
  assumes ra_omega_unfold: "y⇧^ω = y * y⇧^ω"
  assumes ra_omega_induct: "x ≤ z ⊔ y * x ⟶ x ≤ y⇧^ω ⊔ y⇧^⋆ * z"
begin

subclass bounded_omega_algebra
  apply unfold_locales
  using ra_star_left_unfold apply blast
  using ra_star_left_induct apply blast
  using ra_star_right_induct apply blast
  using ra_omega_unfold apply blast
  using ra_omega_induct by blast

end

text ‹Theorem 38›

sublocale omega_relation_algebra < n_omega_algebra where sup = sup and bot = bot and top = top and inf = inf and n = N and L = top and apx = greater_eq and Omega = "λx . N(x⇧^ω) * top ⊔ x⇧^⋆"
  apply unfold_locales
  apply simp
  using n_split_omega_mult omega_vector star_mult_omega apply force
  by simp

end

Theory Domain

(* Title:      Domain
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Domain›

theory Domain

imports Stone_Relation_Algebras.Semirings Tests

begin

context idempotent_left_semiring
begin

sublocale ils: il_semiring where inf = times and sup = sup and bot = bot and less_eq = less_eq and less = less and top = 1
  apply unfold_locales
  apply (simp add: sup_assoc)
  apply (simp add: sup_commute)
  apply simp
  apply simp
  apply (simp add: mult_assoc)
  apply (simp add: mult_right_dist_sup)
  apply simp
  apply simp
  apply simp
  apply (simp add: mult_right_isotone)
  apply (simp add: le_iff_sup)
  by (simp add: less_le_not_le)

end

class left_zero_domain_semiring = idempotent_left_zero_semiring + dom +
  assumes d_restrict: "x ⊔ d(x) * x = d(x) * x"
  assumes d_mult_d  : "d(x * y) = d(x * d(y))"
  assumes d_plus_one: "d(x) ⊔ 1 = 1"
  assumes d_zero    : "d(bot) = bot"
  assumes d_dist_sup: "d(x ⊔ y) = d(x) ⊔ d(y)"
begin

text ‹Many lemmas in this class are taken from Georg Struth's theories.›

lemma d_restrict_equals:
  "x = d(x) * x"
  by (metis sup_commute d_plus_one d_restrict mult_left_one mult_right_dist_sup)

lemma d_involutive:
  "d(d(x)) = d(x)"
  by (metis d_mult_d mult_left_one)

lemma d_fixpoint:
  "(∃y . x = d(y)) ⟷ x = d(x)"
  using d_involutive by auto

lemma d_type:
  "∀P . (∀x . x = d(x) ⟶ P(x)) ⟷ (∀x . P(d(x)))"
  by (metis d_involutive)

lemma d_mult_sub:
  "d(x * y) ≤ d(x)"
  by (metis d_dist_sup d_mult_d d_plus_one le_iff_sup mult_left_sub_dist_sup_left mult_1_right)

lemma d_sub_one:
  "x ≤ 1 ⟹ x ≤ d(x)"
  by (metis d_restrict_equals mult_right_isotone mult_1_right)

lemma d_strict:
  "d(x) = bot ⟷ x = bot"
  by (metis d_restrict_equals d_zero mult_left_zero)

lemma d_one:
  "d(1) = 1"
  by (metis d_restrict_equals mult_1_right)

lemma d_below_one:
  "d(x) ≤ 1"
  by (simp add: d_plus_one le_iff_sup)

lemma d_isotone:
  "x ≤ y ⟹ d(x) ≤ d(y)"
  by (metis d_dist_sup le_iff_sup)

lemma d_plus_left_upper_bound:
  "d(x) ≤ d(x ⊔ y)"
  by (simp add: d_isotone)

lemma d_export:
  "d(d(x) * y) = d(x) * d(y)"
  apply (rule order.antisym)
  apply (metis d_below_one d_involutive d_mult_sub d_restrict_equals d_isotone d_mult_d mult_isotone mult_left_one)
  by (metis d_below_one d_sub_one coreflexive_mult_closed d_mult_d)

lemma d_idempotent:
  "d(x) * d(x) = d(x)"
  by (metis d_export d_restrict_equals)

lemma d_commutative:
  "d(x) * d(y) = d(y) * d(x)"
  by (metis ils.il_inf_associative order.antisym d_export d_mult_d d_mult_sub d_one d_restrict_equals mult_isotone mult_left_one)

lemma d_least_left_preserver:
  "x ≤ d(y) * x ⟷ d(x) ≤ d(y)"
  by (metis d_below_one d_involutive d_mult_sub d_restrict_equals order.eq_iff mult_left_isotone mult_left_one)

lemma d_weak_locality:
  "x * y = bot ⟷ x * d(y) = bot"
  by (metis d_mult_d d_strict)

lemma d_sup_closed:
  "d(d(x) ⊔ d(y)) = d(x) ⊔ d(y)"
  by (simp add: d_involutive d_dist_sup)

lemma d_mult_closed:
  "d(d(x) * d(y)) = d(x) * d(y)"
  using d_export d_mult_d by auto

lemma d_mult_left_lower_bound:
  "d(x) * d(y) ≤ d(x)"
  by (metis d_export d_involutive d_mult_sub)

lemma d_mult_greatest_lower_bound:
  "d(x) ≤ d(y) * d(z) ⟷ d(x) ≤ d(y) ∧ d(x) ≤ d(z)"
  by (metis d_commutative d_idempotent d_mult_left_lower_bound mult_isotone order_trans)

lemma d_mult_left_absorb_sup:
  "d(x) * (d(x) ⊔ d(y)) = d(x)"
  by (metis sup_commute d_idempotent d_plus_one mult_left_dist_sup mult_1_right)

lemma d_sup_left_absorb_mult:
  "d(x) ⊔ d(x) * d(y) = d(x)"
  using d_mult_left_lower_bound sup.absorb_iff1 by auto

lemma d_sup_left_dist_mult:
  "d(x) ⊔ d(y) * d(z) = (d(x) ⊔ d(y)) * (d(x) ⊔ d(z))"
  by (smt sup_assoc d_commutative d_idempotent d_mult_left_absorb_sup mult_left_dist_sup mult_right_dist_sup)

lemma d_order:
  "d(x) ≤ d(y) ⟷ d(x) = d(x) * d(y)"
  by (metis d_mult_greatest_lower_bound d_mult_left_absorb_sup le_iff_sup order_refl)

lemma d_mult_below:
  "d(x) * y ≤ y"
  by (metis sup_left_divisibility d_plus_one mult_left_one mult_right_dist_sup)

lemma d_preserves_equation:
  "d(y) * x ≤ x * d(y) ⟷ d(y) * x = d(y) * x * d(y)"
  by (simp add: d_below_one d_idempotent test_preserves_equation)

end

class left_zero_antidomain_semiring = idempotent_left_zero_semiring + dom + uminus +
  assumes a_restrict   : "-x * x = bot"
  assumes a_plus_mult_d: "-(x * y) ⊔ -(x * --y) = -(x * --y)"
  assumes a_complement : "--x ⊔ -x = 1"
  assumes d_def        : "d(x) = --x"
begin

sublocale aa: a_algebra where minus = "λx y . -(-x ⊔ y)" and uminus = uminus and inf = times and sup = sup and bot = bot and less_eq = less_eq and less = less and top = 1
  apply unfold_locales
  apply (simp add: a_restrict)
  using a_complement sup_commute apply fastforce
  apply (simp add: a_plus_mult_d le_iff_sup)
  by simp

subclass left_zero_domain_semiring
  apply unfold_locales
  apply (simp add: d_def aa.double_complement_above)
  apply (simp add: aa.a_d.d3_eq d_def)
  apply (simp add: d_def)
  apply (simp add: d_def)
  by (simp add: d_def aa.l15)

subclass tests
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (simp add: aa.sba_dual.sub_commutative)
  apply (simp add: aa.sba_dual.sub_complement)
  using aa.sba_dual.sub_sup_closed apply simp
  apply simp
  apply simp
  apply (simp add: aa.sba_dual.sub_inf_def)
  apply (simp add: aa.less_eq_inf)
  by (simp add: less_le_not_le)

text ‹Many lemmas in this class are taken from Georg Struth's theories.›

notation
  uminus ("a")

lemma a_greatest_left_absorber:
  "a(x) * y = bot ⟷ a(x) ≤ a(y)"
  by (simp add: aa.l10_iff)

lemma a_mult_d:
  "a(x * y) = a(x * d(y))"
  by (simp add: d_def aa.sba3_complement_inf_double_complement)

lemma a_d_closed:
  "d(a(x)) = a(x)"
  by (simp add: d_def)

lemma a_plus_left_lower_bound:
  "a(x ⊔ y) ≤ a(x)"
  by (simp add: aa.l9)

lemma a_mult_sup:
  "a(x) * (y ⊔ x) = a(x) * y"
  by (simp add: aa.sba3_inf_complement_bot semiring.distrib_left)

lemma a_3:
  "a(x) * a(y) * d(x ⊔ y) = bot"
  using d_weak_locality aa.l12 aa.sba3_inf_complement_bot by force

lemma a_export:
  "a(a(x) * y) = d(x) ⊔ a(y)"
  using a_mult_d d_def aa.sba_dual.sub_inf_def by auto

lemma a_fixpoint:
  "∀x . (a(x) = x ⟶ (∀y . y = bot))"
  by (metis aa.a_d.d_fully_strict aa.sba2_bot_unit aa.sup_idempotent aa.sup_right_zero_var)

lemma a_strict:
  "a(x) = 1 ⟷ x = bot"
  using aa.a_d.d_fully_strict one_def by fastforce

lemma d_complement_zero:
  "d(x) * a(x) = bot"
  by (simp add: aa.sba3_inf_complement_bot d_def)

lemma a_complement_zero:
  "a(x) * d(x) = bot"
  by (simp add: d_def)

lemma a_shunting_zero:
  "a(x) * d(y) = bot ⟷ a(x) ≤ a(y)"
  by (simp add: aa.less_eq_inf_bot d_def)

lemma a_antitone:
  "x ≤ y ⟹ a(y) ≤ a(x)"
  by (simp add: aa.l9)

lemma a_mult_deMorgan:
  "a(a(x) * a(y)) = d(x ⊔ y)"
  by (simp add: aa.sup_demorgan d_def)

lemma a_mult_deMorgan_1:
  "a(a(x) * a(y)) = d(x) ⊔ d(y)"
  by (simp add: a_export d_def)

lemma a_mult_deMorgan_2:
  "a(d(x) * d(y)) = a(x) ⊔ a(y)"
  by (simp add: d_def sup_def)

lemma a_plus_deMorgan:
  "a(a(x) ⊔ a(y)) = d(x) * d(y)"
  by (simp add: aa.sub_sup_demorgan d_def)

lemma a_plus_deMorgan_1:
  "a(d(x) ⊔ d(y)) = a(x) * a(y)"
  by (simp add: aa.sup_demorgan d_def)

lemma a_mult_left_upper_bound:
  "a(x) ≤ a(x * y)"
  using aa.l5 d_def d_mult_sub by auto

lemma d_a_closed:
  "a(d(x)) = a(x)"
  by (simp add: d_def)

lemma a_export_d:
  "a(d(x) * y) = a(x) ⊔ a(y)"
  using a_mult_d a_mult_deMorgan_2 by auto

lemma a_7:
  "d(x) * a(d(y) ⊔ d(z)) = d(x) * a(y) * a(z)"
  by (simp add: a_plus_deMorgan_1 mult_assoc)

lemma d_a_shunting:
  "d(x) * a(y) ≤ d(z) ⟷ d(x) ≤ d(z) ⊔ d(y)"
  using aa.sba_dual.shunting_right d_def by auto

lemma d_d_shunting:
  "d(x) * d(y) ≤ d(z) ⟷ d(x) ≤ d(z) ⊔ a(y)"
  using d_a_shunting d_def by auto

lemma d_cancellation_1:
  "d(x) ≤ d(y) ⊔ (d(x) * a(y))"
  by (metis a_d_closed aa.sba2_export aa.sup_demorgan d_def eq_refl le_supE sup_commute)

lemma d_cancellation_2:
  "(d(z) ⊔ d(y)) * a(y) ≤ d(z)"
  by (metis d_a_shunting d_dist_sup eq_refl)

lemma a_sup_closed:
  "d(a(x) ⊔ a(y)) = a(x) ⊔ a(y)"
  using aa.sub_sup_closed d_def by auto

lemma a_mult_closed:
  "d(a(x) * a(y)) = a(x) * a(y)"
  using a_d_closed aa.l12 by auto

lemma d_a_shunting_zero:
  "d(x) * a(y) = bot ⟷ d(x) ≤ d(y)"
  by (simp add: aa.l10_iff d_def)

lemma d_d_shunting_zero:
  "d(x) * d(y) = bot ⟷ d(x) ≤ a(y)"
  by (simp add: aa.l10_iff d_def)

lemma d_compl_intro:
  "d(x) ⊔ d(y) = d(x) ⊔ a(x) * d(y)"
  by (simp add: aa.sup_complement_intro d_def)

lemma a_compl_intro:
  "a(x) ⊔ a(y) = a(x) ⊔ d(x) * a(y)"
  by (simp add: aa.sup_complement_intro d_def)

lemma kat_2:
  "y * a(z) ≤ a(x) * y ⟹ d(x) * y * a(z) = bot"
  by (smt a_export a_plus_left_lower_bound le_sup_iff d_d_shunting_zero d_export d_strict le_iff_sup mult_assoc)

lemma kat_3:
  "d(x) * y * a(z) = bot ⟹ d(x) * y = d(x) * y * d(z)"
  by (metis a_export_d aa.complement_bot d_complement_zero d_def mult_1_right mult_left_dist_sup sup_bot_left)

lemma kat_4:
  "d(x) * y = d(x) * y * d(z) ⟹ d(x) * y ≤ y * d(z)"
  using d_mult_below mult_assoc by auto

lemma kat_2_equiv:
  "y * a(z) ≤ a(x) * y ⟷ d(x) * y * a(z) = bot"
  apply (rule iffI)
  apply (simp add: kat_2)
  by (metis aa.top_greatest a_complement sup_bot_left d_def mult_left_one mult_right_dist_sup mult_right_isotone mult_1_right)

lemma kat_4_equiv:
  "d(x) * y = d(x) * y * d(z) ⟷ d(x) * y ≤ y * d(z)"
  apply (rule iffI)
  apply (simp add: kat_4)
  apply (rule order.antisym)
  apply (metis d_idempotent le_iff_sup mult_assoc mult_left_dist_sup)
  by (metis d_plus_one le_iff_sup mult_left_dist_sup mult_1_right)

lemma kat_3_equiv_opp:
  "a(z) * y * d(x) = bot ⟷ y * d(x) = d(z) * y * d(x)"
  by (metis a_complement a_restrict sup_bot_left d_a_closed d_def mult_assoc mult_left_one mult_left_zero mult_right_dist_sup)

lemma kat_4_equiv_opp:
  "y * d(x) = d(z) * y * d(x) ⟷ y * d(x) ≤ d(z) * y"
  using kat_2_equiv kat_3_equiv_opp d_def by auto

lemma d_restrict_iff:
  "(x ≤ y) ⟷ (x ≤ d(x) * y)"
  by (metis d_mult_below d_restrict_equals mult_isotone order_lesseq_imp)

lemma d_restrict_iff_1:
  "(d(x) * y ≤ z) ⟷ (d(x) * y ≤ d(x) * z)"
  by (metis sup_commute d_export d_mult_left_lower_bound d_plus_one d_restrict_iff mult_left_isotone mult_left_one mult_right_sub_dist_sup_right order_trans)

end

end

Theory Domain_Iterings

(* Title:      Domain Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Domain Iterings›

theory Domain_Iterings

imports Domain Lattice_Ordered_Semirings Omega_Algebras

begin

class domain_semiring_lattice = left_zero_domain_semiring + lattice_ordered_pre_left_semiring
begin

subclass bounded_idempotent_left_zero_semiring ..

lemma d_top:
  "d(top) = 1"
  by (metis sup_left_top d_dist_sup d_one d_plus_one)

lemma mult_domain_top:
  "x * d(y) * top ≤ d(x * y) * top"
  by (smt d_mult_d d_restrict_equals mult_assoc mult_right_isotone top_greatest)

lemma domain_meet_domain:
  "d(x ⊓ d(y) * z) ≤ d(y)"
  by (metis d_export d_isotone d_mult_greatest_lower_bound inf.cobounded2)

lemma meet_domain:
  "x ⊓ d(y) * z = d(y) * (x ⊓ z)"
  apply (rule order.antisym)
  apply (metis domain_meet_domain d_mult_below d_restrict_equals inf_mono mult_isotone)
  by (meson d_mult_below le_inf_iff mult_left_sub_dist_inf_right)

lemma meet_intro_domain:
  "x ⊓ y = d(y) * x ⊓ y"
  by (metis d_restrict_equals inf_commute meet_domain)

lemma meet_domain_top:
  "x ⊓ d(y) * top = d(y) * x"
  by (simp add: meet_domain)

(*
lemma "d(x) = x * top ⊓ 1" nitpick [expect=genuine,card=3] oops
*)

lemma d_galois:
  "d(x) ≤ d(y) ⟷ x ≤ d(y) * top"
  by (metis d_export d_isotone d_mult_left_absorb_sup d_plus_one d_restrict_equals d_top mult_isotone top.extremum)

lemma vector_meet:
  "x * top ⊓ y ≤ d(x) * y"
  by (metis d_galois d_mult_sub inf.sup_monoid.add_commute inf.sup_right_isotone meet_domain_top)

end

class domain_semiring_lattice_L = domain_semiring_lattice + L +
  assumes l1: "x * L = x * bot ⊔ d(x) * L"
  assumes l2: "d(L) * x ≤ x * d(L)"
  assumes l3: "d(L) * top ≤ L ⊔ d(L * bot) * top"
  assumes l4: "L * top ≤ L"
  assumes l5: "x * bot ⊓ L ≤ (x ⊓ L) * bot"
begin

lemma l8:
  "(x ⊓ L) * bot ≤ x * bot ⊓ L"
  by (meson inf.boundedE inf.boundedI mult_right_sub_dist_inf_left zero_right_mult_decreasing)

lemma l9:
  "x * bot ⊓ L ≤ d(x * bot) * L"
  by (metis vector_meet vector_mult_closed zero_vector)

lemma l10:
  "L * L = L"
  by (metis d_restrict_equals l1 le_iff_sup zero_right_mult_decreasing)

lemma l11:
  "d(x) * L ≤ x * L"
  by (metis l1 sup.cobounded2)

lemma l12:
  "d(x * bot) * L ≤ x * bot"
  by (metis sup_right_divisibility l1 mult_assoc mult_left_zero)

lemma l13:
  "d(x * bot) * L ≤ x"
  using l12 order_trans zero_right_mult_decreasing by blast

lemma l14:
  "x * L ≤ x * bot ⊔ L"
  by (metis d_mult_below l1 sup_right_isotone)

lemma l15:
  "x * d(y) * L = x * bot ⊔ d(x * y) * L"
  by (metis d_commutative d_mult_d d_zero l1 mult_assoc mult_left_zero)

lemma l16:
  "x * top ⊓ L ≤ x * L"
  using inf.order_lesseq_imp l11 vector_meet by blast

lemma l17:
  "d(x) * L ≤ d(x * L) * L"
  by (metis d_mult_below l11 le_infE le_infI meet_intro_domain)

lemma l18:
  "d(x) * L = d(x * L) * L"
  by (simp add: order.antisym d_mult_sub l17 mult_left_isotone)

lemma l19:
  "d(x * top * bot) * L ≤ d(x * L) * L"
  by (metis d_mult_sub l18 mult_assoc mult_left_isotone)

lemma l20:
  "x ≤ y ⟷ x ≤ y ⊔ L ∧ x ≤ y ⊔ d(y * bot) * top"
  apply (rule iffI)
  apply (simp add: le_supI1)
  by (smt sup_commute sup_inf_distrib1 l13 le_iff_sup meet_domain_top)

lemma l21:
  "d(x * bot) * L ≤ x * bot ⊓ L"
  by (simp add: d_mult_below l12)

lemma l22:
  "x * bot ⊓ L = d(x * bot) * L"
  using l21 order.antisym l9 by auto

lemma l23:
  "x * top ⊓ L = d(x) * L"
  apply (rule order.antisym)
  apply (simp add: vector_meet)
  by (metis d_mult_below inf.le_sup_iff inf_top.left_neutral l1 le_supE mult_left_sub_dist_inf_left)

lemma l29:
  "L * d(L) = L"
  by (metis d_preserves_equation d_restrict_equals l2)

lemma l30:
  "d(L) * x ≤ (x ⊓ L) ⊔ d(L * bot) * x"
  by (metis inf.sup_right_divisibility inf_left_commute inf_sup_distrib1 l3 meet_domain_top)

lemma l31:
  "d(L) * x = (x ⊓ L) ⊔ d(L * bot) * x"
  by (smt (z3) l30 d_dist_sup le_iff_sup meet_intro_domain semiring.combine_common_factor sup_commute sup_inf_absorb zero_right_mult_decreasing)

lemma l40:
  "L * x ≤ L"
  by (meson bot_least inf.order_trans l4 semiring.mult_left_mono top.extremum)

lemma l41:
  "L * top = L"
  by (simp add: l40 order.antisym top_right_mult_increasing)

lemma l50:
  "x * bot ⊓ L = (x ⊓ L) * bot"
  using order.antisym l5 l8 by force

lemma l51:
  "d(x * bot) * L = (x ⊓ L) * bot"
  using l22 l50 by auto

lemma l90:
  "L * top * L = L"
  by (simp add: l41 l10)

lemma l91:
  assumes "x = x * top"
    shows "d(L * bot) * x ≤ d(x * bot) * top"
proof -
  have "d(L * bot) * x ≤ d(d(L * bot) * x) * top"
    using d_galois by blast
  also have "... = d(d(L * bot) * d(x)) * top"
    using d_mult_d by auto
  also have "... = d(d(x) * L * bot) * top"
    using d_commutative d_mult_d ils.il_inf_associative by auto
  also have "... ≤ d(x * L * bot) * top"
    by (metis d_isotone l11 mult_left_isotone)
  also have "... ≤ d(x * top * bot) * top"
    by (simp add: d_isotone mult_left_isotone mult_right_isotone)
  finally show ?thesis
    using assms by auto
qed

lemma l92:
  assumes "x = x * top"
    shows "d(L * bot) * x ≤ d((x ⊓ L) * bot) * top"
proof -
  have "d(L * bot) * x = d(L) * d(L * bot) * x"
    using d_commutative d_mult_sub d_order by auto
  also have "... ≤ d(L) * d(x * bot) * top"
    by (metis assms order.eq_iff l91 mult_assoc mult_isotone)
  also have "... = d(d(x * bot) * L) * top"
    by (simp add: d_commutative d_export)
  also have "... ≤ d((x ⊓ L) * bot) * top"
    by (simp add: l51)
  finally show ?thesis
    .
qed

end

class domain_itering_lattice_L = bounded_itering + domain_semiring_lattice_L
begin

lemma mult_L_circ:
  "(x * L)⇧^∘ = 1 ⊔ x * L"
  by (metis circ_back_loop_fixpoint circ_mult l40 le_iff_sup mult_assoc)

lemma mult_L_circ_mult_below:
  "(x * L)⇧^∘ * y ≤ y ⊔ x * L"
  by (smt sup_right_isotone l40 mult_L_circ mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone)

lemma circ_L:
  "L⇧^∘ = L ⊔ 1"
  by (metis sup_commute l10 mult_L_circ)

lemma circ_d0_L:
  "x⇧^∘ * d(x * bot) * L = x⇧^∘ * bot"
  by (metis sup_bot_right circ_loop_fixpoint circ_plus_same d_zero l15 mult_assoc mult_left_zero)

lemma d0_circ_left_unfold:
  "d(x⇧^∘ * bot) = d(x * x⇧^∘ * bot)"
  by (metis sup_commute sup_bot_left circ_loop_fixpoint mult_assoc)

lemma d_circ_import:
  "d(y) * x ≤ x * d(y) ⟹ d(y) * x⇧^∘ = d(y) * (d(y) * x)⇧^∘"
  apply (rule order.antisym)
  apply (simp add: circ_import d_idempotent d_plus_one le_iff_sup)
  using circ_isotone d_mult_below mult_right_isotone by auto

end

class domain_omega_algebra_lattice_L = bounded_left_zero_omega_algebra + domain_semiring_lattice_L
begin

lemma mult_L_star:
  "(x * L)⇧^⋆ = 1 ⊔ x * L"
  by (metis l40 le_iff_sup mult_assoc star.circ_back_loop_fixpoint star.circ_mult)

lemma mult_L_omega:
  "(x * L)⇧^ω ≤ x * L"
  by (metis l40 mult_right_isotone omega_slide)

lemma mult_L_sup_star:
  "(x * L ⊔ y)⇧^⋆ = y⇧^⋆ ⊔ y⇧^⋆ * x * L"
proof (rule order.antisym)
  have "(x * L ⊔ y) * (y⇧^⋆ ⊔ y⇧^⋆ * x * L) = x * L * (y⇧^⋆ ⊔ y⇧^⋆ * x * L) ⊔ y * (y⇧^⋆ ⊔ y⇧^⋆ * x * L)"
    by (simp add: mult_right_dist_sup)
  also have "... ≤ x * L ⊔ y * (y⇧^⋆ ⊔ y⇧^⋆ * x * L)"
    by (metis sup_left_isotone l40 mult_assoc mult_right_isotone)
  also have "... ≤ x * L ⊔ y * y⇧^⋆ ⊔ y⇧^⋆ * x * L"
    by (smt sup_assoc sup_commute sup_ge2 mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
  also have "... ≤ x * L ⊔ y⇧^⋆ ⊔ y⇧^⋆ * x * L"
    by (meson order_refl star.left_plus_below_circ sup_mono)
  also have "... = y⇧^⋆ ⊔ y⇧^⋆ * x * L"
    by (metis sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint star.circ_reflexive star.circ_sup_one_right_unfold star_involutive)
  finally have "1 ⊔ (x * L ⊔ y) * (y⇧^⋆ ⊔ y⇧^⋆ * x * L) ≤ y⇧^⋆ ⊔ y⇧^⋆ * x * L"
    by (meson le_supI le_supI1 star.circ_reflexive)
  thus "(x * L ⊔ y)⇧^⋆ ≤ y⇧^⋆ ⊔ y⇧^⋆ * x * L"
    using star_left_induct by fastforce
next
  show "y⇧^⋆ ⊔ y⇧^⋆ * x * L ≤ (x * L ⊔ y)⇧^⋆"
    by (metis sup_commute le_sup_iff mult_assoc star.circ_increasing star.circ_mult_upper_bound star.circ_sub_dist)
qed

lemma mult_L_sup_omega:
  "(x * L ⊔ y)⇧^ω ≤ y⇧^ω ⊔ y⇧^⋆ * x * L"
proof -
  have 1: "(y⇧^⋆ * x * L)⇧^ω ≤ y⇧^ω ⊔ y⇧^⋆ * x * L"
    by (simp add: le_supI2 mult_L_omega)
  have "(y⇧^⋆ * x * L)⇧^⋆ * y⇧^ω ≤ y⇧^ω ⊔ y⇧^⋆ * x * L"
    by (metis sup_right_isotone l40 mult_assoc mult_right_isotone star_left_induct)
  thus ?thesis
    using 1 by (simp add: ils.il_inf_associative omega_decompose sup_monoid.add_commute)
qed

end

sublocale domain_omega_algebra_lattice_L < dL_star: itering where circ = star ..

sublocale domain_omega_algebra_lattice_L < dL_star: domain_itering_lattice_L where circ = star ..

context domain_omega_algebra_lattice_L
begin

lemma d0_star_below_d0_omega:
  "d(x⇧^⋆ * bot) ≤ d(x⇧^ω * bot)"
  by (simp add: d_isotone star_bot_below_omega_bot)

lemma d0_below_d0_omega:
  "d(x * bot) ≤ d(x⇧^ω * bot)"
  by (metis d0_star_below_d0_omega d_isotone mult_left_isotone order_trans star.circ_increasing)

lemma star_L_split:
  assumes "y ≤ z"
      and "x * z * L ≤ x * bot ⊔ z * L"
    shows "x⇧^⋆ * y * L ≤ x⇧^⋆ * bot ⊔ z * L"
proof -
  have "x * (x⇧^⋆ * bot ⊔ z * L) ≤ x⇧^⋆ * bot ⊔ x * z * L"
    by (metis sup_bot_right order.eq_iff mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
  also have "... ≤ x⇧^⋆ * bot ⊔ x * bot ⊔ z * L"
    using assms(2) semiring.add_left_mono sup_monoid.add_assoc by auto
  also have "... = x⇧^⋆ * bot ⊔ z * L"
    using mult_isotone star.circ_increasing sup.absorb_iff1 by force
  finally have "y * L ⊔ x * (x⇧^⋆ * bot ⊔ z * L) ≤ x⇧^⋆ * bot ⊔ z * L"
    by (simp add: assms(1) le_supI1 mult_left_isotone sup_monoid.add_commute)
  thus ?thesis
    by (simp add: star_left_induct mult.assoc)
qed

lemma star_L_split_same:
  "x * y * L ≤ x * bot ⊔ y * L ⟹ x⇧^⋆ * y * L = x⇧^⋆ * bot ⊔ y * L"
  apply (rule order.antisym)
  using star_L_split apply blast
  by (metis bot_least ils.il_inf_associative le_supI mult_isotone mult_left_one order_refl star.circ_reflexive)

lemma star_d_L_split_equal:
  "d(x * y) ≤ d(y) ⟹ x⇧^⋆ * d(y) * L = x⇧^⋆ * bot ⊔ d(y) * L"
  by (metis sup_right_isotone l15 le_iff_sup mult_right_sub_dist_sup_left star_L_split_same)

lemma d0_omega_mult:
  "d(x⇧^ω * y * bot) = d(x⇧^ω * bot)"
  apply (rule order.antisym)
  apply (simp add: d_isotone mult_isotone omega_sub_vector)
  by (metis d_isotone mult_assoc mult_right_isotone bot_least)

lemma d_omega_export:
  "d(y) * x ≤ x * d(y) ⟹ d(y) * x⇧^ω = (d(y) * x)⇧^ω"
  apply (rule order.antisym)
  apply (simp add: d_preserves_equation omega_simulation)
  by (smt le_iff_sup mult_left_dist_sup omega_simulation_2 omega_slide)

lemma d_omega_import:
  "d(y) * x ≤ x * d(y) ⟹ d(y) * x⇧^ω = d(y) * (d(y) * x)⇧^ω"
  using d_idempotent omega_import order.refl by auto

lemma star_d_omega_top:
  "x⇧^⋆ * d(x⇧^ω) * top = x⇧^⋆ * bot ⊔ d(x⇧^ω) * top"
  apply (rule order.antisym)
  apply (metis le_supI2 mult_domain_top star_mult_omega)
  by (metis ils.il_inf_associative le_supI mult_left_one mult_left_sub_dist_sup_right mult_right_sub_dist_sup_left star.circ_right_unfold_1 sup_monoid.add_0_right)

lemma omega_meet_L:
  "x⇧^ω ⊓ L = d(x⇧^ω) * L"
  by (metis l23 omega_vector)

(*
lemma d_star_mult: "d(x * y) ≤ d(y) ⟹ d(x⇧^⋆ * y) = d(x⇧^⋆ * bot) ⊔ d(y)" oops
lemma d0_split_omega_omega: "x⇧^ω ≤ x⇧^ω * bot ⊔ d(x⇧^ω ⊓ L) * top" nitpick [expect=genuine,card=2] oops
*)

end

end

Theory Domain_Recursion

(* Title:      Domain Recursion
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Domain Recursion›

theory Domain_Recursion

imports Domain_Iterings Approximation

begin

class domain_semiring_lattice_apx = domain_semiring_lattice_L + apx +
  assumes apx_def: "x ⊑ y ⟷ x ≤ y ⊔ L ∧ d(L) * y ≤ x ⊔ d(x * bot) * top"
begin

lemma apx_transitive:
  assumes "x ⊑ y"
      and "y ⊑ z"
    shows "x ⊑ z"
proof -
  have 1: "x ≤ z ⊔ L"
    by (smt assms sup_assoc sup_commute apx_def le_iff_sup)
  have "d(d(L) * y * bot) * top ≤ d((x ⊔ d(x * bot) * top) * bot) * top"
    by (metis assms(1) apx_def d_isotone mult_left_isotone)
  also have "... ≤ d(x * bot) * top"
    by (metis le_sup_iff d_galois mult_left_isotone mult_right_dist_sup order_refl zero_right_mult_decreasing)
  finally have 2: "d(d(L) * y * bot) * top ≤ d(x * bot) * top"
    .
  have "d(L) * z = d(L) * (d(L) * z)"
    by (simp add: d_idempotent ils.il_inf_associative)
  also have "... ≤ d(L) * y ⊔ d(d(L) * y * bot) * top"
    by (metis assms(2) apx_def d_export mult_assoc mult_left_dist_sup mult_right_isotone)
  also have "... ≤ x ⊔ d(x * bot) * top"
    using 2 by (meson assms(1) apx_def le_supI2 sup_least)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

lemma apx_meet_L:
  assumes "y ⊑ x"
    shows "x ⊓ L ≤ y ⊓ L"
proof -
  have "x ⊓ L = d(L) * x ⊓ L"
    using meet_intro_domain by auto
  also have "... ≤ (y ⊔ d(y * bot) * top) ⊓ L"
    using assms apx_def inf.sup_left_isotone by blast
  also have "... ≤ y"
    by (simp add: inf.sup_monoid.add_commute inf_sup_distrib1 l13 meet_domain_top)
  finally show ?thesis
    by simp
qed

lemma sup_apx_left_isotone:
  assumes "x ⊑ y"
    shows "x ⊔ z ⊑ y ⊔ z"
proof -
  have 1: "x ⊔ z ≤ y ⊔ z ⊔ L"
    by (smt assms sup_assoc sup_commute sup_left_isotone apx_def)
  have "d(L) * (y ⊔ z) = d(L) * y ⊔ d(L) * z"
    by (simp add: mult_left_dist_sup)
  also have "... ≤ d(L) * y ⊔ z"
    by (simp add: d_mult_below le_supI1 sup_commute)
  also have "... ≤ x ⊔ d(x * bot) * top ⊔ z"
    using assms apx_def sup_left_isotone by blast
  also have "... ≤ x ⊔ z ⊔ d((x ⊔ z) * bot) * top"
    by (simp add: d_dist_sup le_iff_sup semiring.distrib_right sup.left_commute sup_monoid.add_assoc)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

subclass apx_biorder
  apply unfold_locales
  apply (metis le_sup_iff sup_ge1 apx_def d_plus_one mult_left_one mult_right_dist_sup)
  apply (meson apx_meet_L order.antisym apx_def relative_equality sup_same_context)
  using apx_transitive by blast

lemma mult_apx_left_isotone:
  assumes "x ⊑ y"
    shows "x * z ⊑ y * z"
proof -
  have "x * z ≤ y * z ⊔ L * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  hence 1: "x * z ≤ y * z ⊔ L"
    using l40 order_lesseq_imp semiring.add_left_mono by blast
  have "d(L) * y * z ≤ x * z ⊔ d(x * bot) * top * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  also have "... ≤ x * z ⊔ d(x * z * bot) * top"
    by (metis sup_right_isotone d_isotone mult_assoc mult_isotone mult_right_isotone top_greatest bot_least)
  finally show ?thesis
    using 1 by (simp add: apx_def mult_assoc)
qed

lemma mult_apx_right_isotone:
  assumes "x ⊑ y"
    shows "z * x ⊑ z * y"
proof -
  have "z * x ≤ z * y ⊔ z * L"
    by (metis assms apx_def mult_left_dist_sup mult_right_isotone)
  also have "... ≤ z * y ⊔ z * bot ⊔ L"
    using l14 semiring.add_left_mono sup_monoid.add_assoc by auto
  finally have 1: "z * x ≤ z * y ⊔ L"
    using mult_right_isotone sup.order_iff by auto
  have "d(L) * z * y ≤ z * d(L) * y"
    by (simp add: l2 mult_left_isotone)
  also have "... ≤ z * (x ⊔ d(x * bot) * top)"
    by (metis assms apx_def mult_assoc mult_right_isotone)
  also have "... = z * x ⊔ z * d(x * bot) * top"
    by (simp add: mult_left_dist_sup mult_assoc)
  also have "... ≤ z * x ⊔ d(z * x * bot) * top"
    by (metis sup_right_isotone mult_assoc mult_domain_top)
  finally show ?thesis
    using 1 by (simp add: apx_def mult_assoc)
qed

subclass apx_semiring
  apply unfold_locales
  apply (metis sup_ge2 apx_def l3 mult_right_isotone order_trans top_greatest)
  apply (simp add: sup_apx_left_isotone)
  apply (simp add: mult_apx_left_isotone)
  by (simp add: mult_apx_right_isotone)

lemma meet_L_apx_isotone:
  "x ⊑ y ⟹ x ⊓ L ⊑ y ⊓ L"
  by (smt (z3) inf.cobounded2 sup.coboundedI1 sup_absorb sup_commute apx_def apx_meet_L d_restrict_equals l20 inf_commute meet_domain)

definition kappa_apx_meet :: "('a ⇒ 'a) ⇒ bool"
  where "kappa_apx_meet f ≡ apx.has_least_fixpoint f ∧ has_apx_meet (μ f) (ν f) ∧ κ f = μ f △ ν f"

definition kappa_mu_nu :: "('a ⇒ 'a) ⇒ bool"
  where "kappa_mu_nu f ≡ apx.has_least_fixpoint f ∧ κ f = μ f ⊔ (ν f ⊓ L)"

definition nu_below_mu_nu :: "('a ⇒ 'a) ⇒ bool"
  where "nu_below_mu_nu f ≡ d(L) * ν f ≤ μ f ⊔ (ν f ⊓ L) ⊔ d(ν f * bot) * top"

definition nu_below_mu_nu_2 :: "('a ⇒ 'a) ⇒ bool"
  where "nu_below_mu_nu_2 f ≡ d(L) * ν f ≤ μ f ⊔ (ν f ⊓ L) ⊔ d((μ f ⊔ (ν f ⊓ L)) * bot) * top"

definition mu_nu_apx_nu :: "('a ⇒ 'a) ⇒ bool"
  where "mu_nu_apx_nu f ≡ μ f ⊔ (ν f ⊓ L) ⊑ ν f"

definition mu_nu_apx_meet :: "('a ⇒ 'a) ⇒ bool"
  where "mu_nu_apx_meet f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f = μ f ⊔ (ν f ⊓ L)"

definition apx_meet_below_nu :: "('a ⇒ 'a) ⇒ bool"
  where "apx_meet_below_nu f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f ≤ ν f"

lemma mu_below_l:
  "μ f ≤ μ f ⊔ (ν f ⊓ L)"
  by simp

lemma l_below_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ μ f ⊔ (ν f ⊓ L) ≤ ν f"
  by (simp add: mu_below_nu)

lemma n_l_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ (μ f ⊔ (ν f ⊓ L)) ⊓ L = ν f ⊓ L"
  by (meson l_below_nu inf.sup_same_context inf_le1 order_trans sup.cobounded2)

lemma l_apx_mu:
  "μ f ⊔ (ν f ⊓ L) ⊑ μ f"
  by (simp add: apx_def d_mult_below le_supI1 sup_inf_distrib1)

lemma nu_below_mu_nu_nu_below_mu_nu_2:
  assumes "nu_below_mu_nu f"
    shows "nu_below_mu_nu_2 f"
proof -
  have "d(L) * ν f = d(L) * (d(L) * ν f)"
    by (simp add: d_idempotent ils.il_inf_associative)
  also have "... ≤ d(L) * (μ f ⊔ (ν f ⊓ L) ⊔ d(ν f * bot) * top)"
    using assms mult_isotone nu_below_mu_nu_def by blast
  also have "... = d(L) * (μ f ⊔ (ν f ⊓ L)) ⊔ d(L) * d(ν f * bot) * top"
    by (simp add: ils.il_inf_associative mult_left_dist_sup)
  also have "... ≤ μ f ⊔ (ν f ⊓ L) ⊔ d(L) * d(ν f * bot) * top"
    using d_mult_below sup_left_isotone by auto
  also have "... = μ f ⊔ (ν f ⊓ L) ⊔ d(d(ν f * bot) * L) * top"
    by (simp add: d_commutative d_export)
  also have "... = μ f ⊔ (ν f ⊓ L) ⊔ d((ν f ⊓ L) * bot) * top"
    using l51 by auto
  also have "... ≤ μ f ⊔ (ν f ⊓ L) ⊔ d((μ f ⊔ (ν f ⊓ L)) * bot) * top"
    by (meson d_isotone inf.eq_refl mult_isotone semiring.add_left_mono sup.cobounded2)
  finally show ?thesis
    using nu_below_mu_nu_2_def by auto
qed

lemma nu_below_mu_nu_2_nu_below_mu_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "nu_below_mu_nu_2 f"
    shows "nu_below_mu_nu f"
proof -
  have "d(L) * ν f ≤ μ f ⊔ (ν f ⊓ L) ⊔ d((μ f ⊔ (ν f ⊓ L)) * bot) * top"
    using assms(3) nu_below_mu_nu_2_def by blast
  also have "... ≤ μ f ⊔ (ν f ⊓ L) ⊔ d(ν f * bot) * top"
    by (metis assms(1,2) d_isotone inf.sup_monoid.add_commute inf.sup_right_divisibility le_supI le_supI2 mu_below_nu mult_left_isotone sup_left_divisibility)
  finally show ?thesis
    by (simp add: nu_below_mu_nu_def)
qed

lemma nu_below_mu_nu_equivalent:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ (nu_below_mu_nu f ⟷ nu_below_mu_nu_2 f)"
  using nu_below_mu_nu_2_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by blast

lemma nu_below_mu_nu_2_mu_nu_apx_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "nu_below_mu_nu_2 f"
    shows "mu_nu_apx_nu f"
proof -
  have "μ f ⊔ (ν f ⊓ L) ≤ ν f ⊔ L"
    using assms(1,2) l_below_nu le_supI1 by blast
  thus ?thesis
    using assms(3) apx_def mu_nu_apx_nu_def nu_below_mu_nu_2_def by blast
qed

lemma mu_nu_apx_nu_mu_nu_apx_meet:
  assumes "mu_nu_apx_nu f"
    shows "mu_nu_apx_meet f"
proof -
  let ?l = "μ f ⊔ (ν f ⊓ L)"
  have "is_apx_meet (μ f) (ν f) ?l"
    apply (unfold is_apx_meet_def, intro conjI)
    apply (simp add: l_apx_mu)
    using assms mu_nu_apx_nu_def apply blast
    by (metis apx_meet_L le_supI2 sup.order_iff sup_apx_left_isotone sup_inf_absorb)
  thus ?thesis
    by (smt apx_meet_char mu_nu_apx_meet_def)
qed

lemma mu_nu_apx_meet_apx_meet_below_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ mu_nu_apx_meet f ⟹ apx_meet_below_nu f"
  using apx_meet_below_nu_def l_below_nu mu_nu_apx_meet_def by auto

lemma apx_meet_below_nu_nu_below_mu_nu_2:
  assumes "apx_meet_below_nu f"
    shows "nu_below_mu_nu_2 f"
proof -
  let ?l = "μ f ⊔ (ν f ⊓ L)"
  have "∀m . m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f ⟶ d(L) * ν f ≤ ?l ⊔ d(?l * bot) * top"
  proof
    fix m
    show "m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f ⟶ d(L) * ν f ≤ ?l ⊔ d(?l * bot) * top"
    proof
      assume 1: "m ⊑ μ f ∧ m ⊑ ν f ∧ m ≤ ν f"
      hence "m ≤ ?l"
        by (metis apx_def ils.il_associative sup.orderE sup.orderI sup_inf_distrib1 sup_inf_distrib2)
      hence "m ⊔ d(m * bot) * top ≤ ?l ⊔ d(?l * bot) * top"
        by (meson d_isotone order.trans le_supI le_supI2 mult_left_isotone sup.cobounded1)
      thus "d(L) * ν f ≤ ?l ⊔ d(?l * bot) * top"
        using 1 apx_def order_lesseq_imp by blast
    qed
  qed
  thus ?thesis
    by (smt (verit) assms apx_meet_below_nu_def apx_meet_same apx_meet_unique is_apx_meet_def nu_below_mu_nu_2_def)
qed

lemma has_apx_least_fixpoint_kappa_apx_meet:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "apx.has_least_fixpoint f"
    shows "kappa_apx_meet f"
proof -
  have 1: "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ d(L) * κ f ≤ w ⊔ d(w * bot) * top"
    by (metis assms(2,3) apx_def mult_right_isotone order_trans kappa_below_nu)
  have "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ w ≤ κ f ⊔ L"
    by (metis assms(1,3) sup_left_isotone apx_def mu_below_kappa order_trans)
  hence "∀w . w ⊑ μ f ∧ w ⊑ ν f ⟶ w ⊑ κ f"
    using 1 apx_def by blast
  hence "is_apx_meet (μ f) (ν f) (κ f)"
    using assms apx_meet_char is_apx_meet_def kappa_apx_below_mu kappa_apx_below_nu kappa_apx_meet_def by presburger
  thus ?thesis
    by (simp add: assms(3) kappa_apx_meet_def apx_meet_char)
qed

lemma kappa_apx_meet_apx_meet_below_nu:
  "has_greatest_fixpoint f ⟹ kappa_apx_meet f ⟹ apx_meet_below_nu f"
  using apx_meet_below_nu_def kappa_apx_meet_def kappa_below_nu by force

lemma apx_meet_below_nu_kappa_mu_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "isotone f"
      and "apx.isotone f"
      and "apx_meet_below_nu f"
    shows "kappa_mu_nu f"
proof -
  let ?l = "μ f ⊔ (ν f ⊓ L)"
  let ?m = "μ f △ ν f"
  have 1: "?m = ?l"
    by (metis assms(1,2,5) apx_meet_below_nu_nu_below_mu_nu_2 mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu)
  have 2: "?l ≤ f(?l) ⊔ L"
  proof -
    have "?l ≤ μ f ⊔ L"
      using sup_right_isotone by auto
    also have "... = f(μ f) ⊔ L"
      by (simp add: assms(1) mu_unfold)
    also have "... ≤ f(?l) ⊔ L"
      by (metis assms(3) sup_left_isotone sup_ge1 isotone_def)
    finally show ?thesis
      .
  qed
  have "d(L) * f(?l) ≤ ?l ⊔ d(?l * bot) * top"
  proof -
    have "d(L) * f(?l) ≤ d(L) * f(ν f)"
      by (metis assms(1-3) l_below_nu mult_right_isotone ord.isotone_def)
    also have "... = d(L) * ν f"
      by (metis assms(2) nu_unfold)
    also have "... ≤ ?l ⊔ d(?l * bot) * top"
      using apx_meet_below_nu_nu_below_mu_nu_2 assms(5) nu_below_mu_nu_2_def by blast
    finally show ?thesis
      .
  qed
  hence 3: "?l ⊑ f(?l)"
    using 2 by (simp add: apx_def)
  have 4: "f(?l) ⊑ μ f"
  proof -
    have "?l ⊑ μ f"
      by (simp add: l_apx_mu)
    thus ?thesis
      by (metis assms(1,4) mu_unfold ord.isotone_def)
  qed
  have 5: "f(?l) ⊑ ν f"
  proof -
    have "?l ⊑ ν f"
      by (meson apx_meet_below_nu_nu_below_mu_nu_2 assms(1,2,5) l_below_nu apx_def le_supI1 nu_below_mu_nu_2_def)
    thus ?thesis
      by (metis assms(2,4) nu_unfold ord.isotone_def)
  qed
  hence "f(?l) ⊑ ?l"
    using 1 4 apx_meet_below_nu_def assms(5) apx_greatest_lower_bound by fastforce
  hence 6: "f(?l) = ?l"
    using 3 apx.order.antisym by blast
  have "∀y . f(y) = y ⟶ ?l ⊑ y"
  proof
    fix y
    show "f(y) = y ⟶ ?l ⊑ y"
    proof
      assume 7: "f(y) = y"
      hence 8: "?l ≤ y ⊔ L"
        using assms(1) inf.cobounded2 is_least_fixpoint_def least_fixpoint semiring.add_mono by blast
      have "y ≤ ν f"
        using 7 assms(2) greatest_fixpoint is_greatest_fixpoint_def by auto
      hence "d(L) * y ≤ ?l ⊔ d(?l * bot) * top"
        using 3 5 by (smt (z3) apx.order.trans apx_def semiring.distrib_left sup.absorb_iff2 sup_assoc)
      thus "?l ⊑ y"
        using 8 by (simp add: apx_def)
    qed
  qed
  thus ?thesis
    using 1 6 by (smt (verit) kappa_mu_nu_def apx.is_least_fixpoint_def apx.least_fixpoint_char)
qed

lemma kappa_mu_nu_has_apx_least_fixpoint:
  "kappa_mu_nu f ⟹ apx.has_least_fixpoint f"
  by (simp add: kappa_mu_nu_def)

lemma nu_below_mu_nu_kappa_mu_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ isotone f ⟹ apx.isotone f ⟹ nu_below_mu_nu f ⟹ kappa_mu_nu f"
  using apx_meet_below_nu_kappa_mu_nu mu_nu_apx_meet_apx_meet_below_nu mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_nu_below_mu_nu_2 by blast

lemma kappa_mu_nu_nu_below_mu_nu:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ kappa_mu_nu f ⟹ nu_below_mu_nu f"
  by (simp add: apx_meet_below_nu_nu_below_mu_nu_2 has_apx_least_fixpoint_kappa_apx_meet kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_def nu_below_mu_nu_2_nu_below_mu_nu)

definition kappa_mu_nu_L :: "('a ⇒ 'a) ⇒ bool"
  where "kappa_mu_nu_L f ≡ apx.has_least_fixpoint f ∧ κ f = μ f ⊔ d(ν f * bot) * L"

definition nu_below_mu_nu_L :: "('a ⇒ 'a) ⇒ bool"
  where "nu_below_mu_nu_L f ≡ d(L) * ν f ≤ μ f ⊔ d(ν f * bot) * top"

definition mu_nu_apx_nu_L :: "('a ⇒ 'a) ⇒ bool"
  where "mu_nu_apx_nu_L f ≡ μ f ⊔ d(ν f * bot) * L ⊑ ν f"

definition mu_nu_apx_meet_L :: "('a ⇒ 'a) ⇒ bool"
  where "mu_nu_apx_meet_L f ≡ has_apx_meet (μ f) (ν f) ∧ μ f △ ν f = μ f ⊔ d(ν f * bot) * L"

lemma n_below_l:
  "x ⊔ d(y * bot) * L ≤ x ⊔ (y ⊓ L)"
  using d_mult_below l13 sup_right_isotone by auto

lemma n_equal_l:
  assumes "nu_below_mu_nu_L f"
    shows"μ f ⊔ d(ν f * bot) * L = μ f ⊔ (ν f ⊓ L)"
proof -
  have "ν f ⊓ L ≤ (μ f ⊔ d(ν f * bot) * top) ⊓ L"
    using assms l31 nu_below_mu_nu_L_def by force
  also have "... ≤ μ f ⊔ d(ν f * bot) * L"
    using distrib(4) inf.sup_monoid.add_commute meet_domain_top sup_left_isotone by force
  finally have "μ f ⊔ (ν f ⊓ L) ≤ μ f ⊔ d(ν f * bot) * L"
    by auto
  thus ?thesis
    by (meson order.antisym n_below_l)
qed

lemma nu_below_mu_nu_L_nu_below_mu_nu:
  "nu_below_mu_nu_L f ⟹ nu_below_mu_nu f"
  using order_lesseq_imp sup.cobounded1 sup_left_isotone nu_below_mu_nu_L_def nu_below_mu_nu_def by blast

lemma nu_below_mu_nu_L_kappa_mu_nu_L:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ isotone f ⟹ apx.isotone f ⟹ nu_below_mu_nu_L f ⟹ kappa_mu_nu_L f"
  using kappa_mu_nu_L_def kappa_mu_nu_def n_equal_l nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_kappa_mu_nu by auto

lemma nu_below_mu_nu_L_mu_nu_apx_nu_L:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ nu_below_mu_nu_L f ⟹ mu_nu_apx_nu_L f"
  using mu_nu_apx_nu_L_def mu_nu_apx_nu_def n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by auto

lemma nu_below_mu_nu_L_mu_nu_apx_meet_L:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ nu_below_mu_nu_L f ⟹ mu_nu_apx_meet_L f"
  using mu_nu_apx_meet_L_def mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by auto

lemma mu_nu_apx_nu_L_nu_below_mu_nu_L:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "mu_nu_apx_nu_L f"
    shows "nu_below_mu_nu_L f"
proof -
  let ?n = "μ f ⊔ d(ν f * bot) * L"
  let ?l = "μ f ⊔ (ν f ⊓ L)"
  have "d(L) * ν f ≤ ?n ⊔ d(?n * bot) * top"
    using assms(3) apx_def mu_nu_apx_nu_L_def by blast
  also have "... ≤ ?n ⊔ d(?l * bot) * top"
    using d_isotone mult_left_isotone semiring.add_left_mono n_below_l by auto
  also have "... ≤ ?n ⊔ d(ν f * bot) * top"
    by (meson assms(1,2) l_below_nu d_isotone mult_left_isotone sup_right_isotone)
  finally show ?thesis
    by (metis sup_assoc sup_right_top mult_left_dist_sup nu_below_mu_nu_L_def)
qed

lemma kappa_mu_nu_L_mu_nu_apx_nu_L:
  "has_greatest_fixpoint f ⟹ kappa_mu_nu_L f ⟹ mu_nu_apx_nu_L f"
  using kappa_mu_nu_L_def kappa_apx_below_nu mu_nu_apx_nu_L_def by force

lemma mu_nu_apx_meet_L_mu_nu_apx_nu_L:
  "mu_nu_apx_meet_L f ⟹ mu_nu_apx_nu_L f"
  using apx_greatest_lower_bound mu_nu_apx_meet_L_def mu_nu_apx_nu_L_def by fastforce

lemma kappa_mu_nu_L_nu_below_mu_nu_L:
  "has_least_fixpoint f ⟹ has_greatest_fixpoint f ⟹ kappa_mu_nu_L f ⟹ nu_below_mu_nu_L f"
  using kappa_mu_nu_L_mu_nu_apx_nu_L mu_nu_apx_nu_L_nu_below_mu_nu_L by auto

end

class itering_apx = domain_itering_lattice_L + domain_semiring_lattice_apx
begin

lemma circ_apx_isotone:
  assumes "x ⊑ y"
    shows "x⇧^∘ ⊑ y⇧^∘"
proof -
  have 1: "x ≤ y ⊔ L ∧ d(L) * y ≤ x ⊔ d(x * bot) * top"
    using assms apx_def by auto
  have "d(L) * y⇧^∘ ≤ (d(L) * y)⇧^∘"
    by (metis d_circ_import d_mult_below l2)
  also have "... ≤ x⇧^∘ * (d(x * bot) * top * x⇧^∘)⇧^∘"
    using 1 by (metis circ_sup_1 circ_isotone)
  also have "... = x⇧^∘ ⊔ x⇧^∘ * d(x * bot) * top"
    by (metis circ_left_top mult_assoc mult_left_dist_sup mult_1_right mult_top_circ)
  also have "... ≤ x⇧^∘ ⊔ d(x⇧^∘ * x * bot) * top"
    by (metis sup_right_isotone mult_assoc mult_domain_top)
  finally have 2: "d(L) * y⇧^∘ ≤ x⇧^∘ ⊔ d(x⇧^∘ * bot) * top"
    using circ_plus_same d0_circ_left_unfold by auto
  have "x⇧^∘ ≤ y⇧^∘ * L⇧^∘"
    using 1 by (metis circ_sup_1 circ_back_loop_fixpoint circ_isotone l40 le_iff_sup mult_assoc)
  also have "... = y⇧^∘ ⊔ y⇧^∘ * L"
    by (simp add: circ_L mult_left_dist_sup sup_commute)
  also have "... ≤ y⇧^∘ ⊔ y⇧^∘ * bot ⊔ L"
    using l14 semiring.add_left_mono sup_monoid.add_assoc by auto
  finally have "x⇧^∘ ≤ y⇧^∘ ⊔ L"
    using sup.absorb_iff1 zero_right_mult_decreasing by auto
  thus ?thesis
    using 2 by (simp add: apx_def)
qed

end

class omega_algebra_apx = domain_omega_algebra_lattice_L + domain_semiring_lattice_apx

sublocale omega_algebra_apx < star: itering_apx where circ = star ..

context omega_algebra_apx
begin

lemma omega_apx_isotone:
  assumes "x ⊑ y"
    shows "x⇧^ω ⊑ y⇧^ω"
proof -
  have 1: "x ≤ y ⊔ L ∧ d(L) * y ≤ x ⊔ d(x * bot) * top"
    using assms apx_def by auto
  have "d(L) * y⇧^ω = (d(L) * y)⇧^ω"
    by (simp add: d_omega_export l2)
  also have "... ≤ (x ⊔ d(x * bot) * top)⇧^ω"
    using 1 by (simp add: omega_isotone)
  also have "... = (x⇧^⋆ * d(x * bot) * top)⇧^ω ⊔ (x⇧^⋆ * d(x * bot) * top)⇧^⋆ * x⇧^ω"
    by (simp add: ils.il_inf_associative omega_decompose)
  also have "... ≤ x⇧^⋆ * d(x * bot) * top ⊔ (x⇧^⋆ * d(x * bot) * top)⇧^⋆ * x⇧^ω"
    using mult_top_omega sup_left_isotone by blast
  also have "... = x⇧^⋆ * d(x * bot) * top ⊔ (1 ⊔ x⇧^⋆ * d(x * bot) * top * (x⇧^⋆ * d(x * bot) * top)⇧^⋆) * x⇧^ω"
    by (simp add: star_left_unfold_equal)
  also have "... ≤ x⇧^ω ⊔ x⇧^⋆ * d(x * bot) * top"
    by (smt (verit, ccfv_threshold) sup_mono le_sup_iff mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone order_refl top_greatest)
  also have "... ≤ x⇧^ω ⊔ d(x⇧^⋆ * x * bot) * top"
    by (metis sup_right_isotone mult_assoc mult_domain_top)
  also have "... ≤ x⇧^ω ⊔ d(x⇧^⋆ * bot) * top"
    by (simp add: dL_star.d0_circ_left_unfold star_plus)
  finally have 2: "d(L) * y⇧^ω ≤ x⇧^ω ⊔ d(x⇧^ω * bot) * top"
    by (meson sup_right_isotone d0_star_below_d0_omega mult_left_isotone order_trans)
  have "x⇧^ω ≤ (y ⊔ L)⇧^ω"
    using 1 by (simp add: omega_isotone)
  also have "... = (y⇧^⋆ * L)⇧^ω ⊔ (y⇧^⋆ * L)⇧^⋆ * y⇧^ω"
    by (simp add: omega_decompose)
  also have "... = y⇧^⋆ * L * (y⇧^⋆ * L)⇧^ω ⊔ (y⇧^⋆ * L)⇧^⋆ * y⇧^ω"
    using omega_unfold by auto
  also have "... ≤ y⇧^⋆ * L ⊔ (y⇧^⋆ * L)⇧^⋆ * y⇧^ω"
    using mult_L_omega omega_unfold sup_left_isotone by auto
  also have "... = y⇧^⋆ * L ⊔ (1 ⊔ y⇧^⋆ * L * (y⇧^⋆ * L)⇧^⋆) * y⇧^ω"
    by (simp add: star_left_unfold_equal)
  also have "... ≤ y⇧^⋆ * L ⊔ y⇧^ω"
    by (simp add: dL_star.mult_L_circ_mult_below star_left_unfold_equal sup_commute)
  also have "... ≤ y⇧^⋆ * bot ⊔ L ⊔ y⇧^ω"
    by (simp add: l14 le_supI1)
  finally have "x⇧^ω ≤ y⇧^ω ⊔ L"
    using star_bot_below_omega sup.left_commute sup.order_iff sup_commute by auto
  thus ?thesis
    using 2 by (simp add: apx_def)
qed

lemma combined_apx_isotone:
  "x ⊑ y ⟹ (x⇧^ω ⊓ L) ⊔ x⇧^⋆ * z ⊑ (y⇧^ω ⊓ L) ⊔ y⇧^⋆ * z"
  using meet_L_apx_isotone mult_apx_left_isotone star.circ_apx_isotone sup_apx_isotone omega_apx_isotone by auto

lemma d_split_nu_mu:
  "d(L) * (y⇧^ω ⊔ y⇧^⋆ * z) ≤ y⇧^⋆ * z ⊔ ((y⇧^ω ⊔ y⇧^⋆ * z) ⊓ L) ⊔ d((y⇧^ω ⊔ y⇧^⋆ * z) * bot) * top"
proof -
  have "d(L) * y⇧^ω ≤ (y⇧^ω ⊓ L) ⊔ d(y⇧^ω * bot) * top"
    using l31 l91 omega_vector sup_right_isotone by auto
  hence "d(L) * (y⇧^ω ⊔ y⇧^⋆ * z) ≤ y⇧^⋆ * z ⊔ (y⇧^ω ⊓ L) ⊔ d(y⇧^ω * bot) * top"
    by (smt sup_assoc sup_commute sup_mono d_mult_below mult_left_dist_sup)
  also have "... ≤ y⇧^⋆ * z ⊔ ((y⇧^ω ⊔ y⇧^⋆ * z) ⊓ L) ⊔ d(y⇧^ω * bot) * top"
    by (simp add: le_supI1 le_supI2)
  also have "... ≤ y⇧^⋆ * z ⊔ ((y⇧^ω ⊔ y⇧^⋆ * z) ⊓ L) ⊔ d((y⇧^ω ⊔ y⇧^⋆ * z) * bot) * top"
    by (meson d_isotone mult_left_isotone sup.cobounded1 sup_right_isotone)
  finally show ?thesis
    .
qed

lemma loop_exists:
  "d(L) * ν (λx . y * x ⊔ z) ≤ μ (λx . y * x ⊔ z) ⊔ (ν (λx . y * x ⊔ z) ⊓ L) ⊔ d(ν (λx . y * x ⊔ z) * bot) * top"
  by (simp add: d_split_nu_mu omega_loop_nu star_loop_mu)

lemma loop_apx_least_fixpoint:
  "apx.is_least_fixpoint (λx . y * x ⊔ z) (μ (λx . y * x ⊔ z) ⊔ (ν (λx . y * x ⊔ z) ⊓ L))"
  using apx.least_fixpoint_char affine_apx_isotone loop_exists affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu kappa_mu_nu_def by auto

lemma loop_has_apx_least_fixpoint:
  "apx.has_least_fixpoint (λx . y * x ⊔ z)"
  by (metis apx.has_least_fixpoint_def loop_apx_least_fixpoint)

lemma loop_semantics:
  "κ (λx . y * x ⊔ z) = μ (λx . y * x ⊔ z) ⊔ (ν (λx . y * x ⊔ z) ⊓ L)"
  using apx.least_fixpoint_char loop_apx_least_fixpoint by auto

lemma loop_semantics_kappa_mu_nu:
  "κ (λx . y * x ⊔ z) = (y⇧^ω ⊓ L) ⊔ y⇧^⋆ * z"
proof -
  have "κ (λx . y * x ⊔ z) = y⇧^⋆ * z ⊔ ((y⇧^ω ⊔ y⇧^⋆ * z) ⊓ L)"
    by (metis loop_semantics omega_loop_nu star_loop_mu)
  thus ?thesis
    by (metis sup.absorb2 sup_commute sup_ge2 sup_inf_distrib1)
qed

lemma loop_semantics_kappa_mu_nu_domain:
  "κ (λx . y * x ⊔ z) = d(y⇧^ω) * L ⊔ y⇧^⋆ * z"
  by (simp add: omega_meet_L loop_semantics_kappa_mu_nu)

lemma loop_semantics_apx_isotone:
  "w ⊑ y ⟹ κ (λx . w * x ⊔ z) ⊑ κ (λx . y * x ⊔ z)"
  by (metis loop_semantics_kappa_mu_nu combined_apx_isotone)

end

end

Theory Extended_Designs

(* Title:      Extended Designs
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Extended Designs›

theory Extended_Designs

imports Omega_Algebras Domain

begin

class domain_semiring_L_below = left_zero_domain_semiring + L +
  assumes L_left_zero_below: "L * x ≤ L"
  assumes mult_L_split: "x * L = x * bot ⊔ d(x) * L"
begin

lemma d_zero_mult_L:
  "d(x * bot) * L ≤ x"
  by (metis le_sup_iff mult_L_split mult_assoc mult_left_zero zero_right_mult_decreasing)

lemma mult_L:
  "x * L ≤ x * bot ⊔ L"
  by (metis sup_right_isotone d_mult_below mult_L_split)

lemma d_mult_L:
  "d(x) * L ≤ x * L"
  by (metis sup_right_divisibility mult_L_split)

lemma d_L_split:
  "x * d(y) * L = x * bot ⊔ d(x * y) * L"
  by (metis d_commutative d_mult_d d_zero mult_L_split mult_assoc mult_left_zero)

lemma d_mult_mult_L:
  "d(x * y) * L ≤ x * d(y) * L"
  using d_L_split by auto

lemma L_L:
  "L * L = L"
  by (metis d_restrict_equals le_iff_sup mult_L_split zero_right_mult_decreasing)

end

class antidomain_semiring_L = left_zero_antidomain_semiring + L +
  assumes d_zero_mult_L: "d(x * bot) * L ≤ x"
  assumes d_L_zero     : "d(L * bot) = 1"
  assumes mult_L       : "x * L ≤ x * bot ⊔ L"
begin

lemma L_left_zero:
  "L * x = L"
  by (metis order.antisym d_L_zero d_zero_mult_L mult_assoc mult_left_one mult_left_zero zero_right_mult_decreasing)

subclass domain_semiring_L_below
  apply unfold_locales
  apply (simp add: L_left_zero)
  apply (rule order.antisym)
  apply (smt d_restrict_equals le_iff_sup mult_L mult_assoc mult_left_dist_sup)
  by (metis le_sup_iff d_L_zero d_mult_d d_zero_mult_L mult_assoc mult_right_isotone mult_1_right bot_least)

end

class ed_below = bounded_left_zero_omega_algebra + domain_semiring_L_below + Omega +
  assumes Omega_def: "x⇧^Ω = d(x⇧^ω) * L ⊔ x⇧^⋆"
begin

lemma Omega_isotone:
  "x ≤ y ⟹ x⇧^Ω ≤ y⇧^Ω"
  by (metis Omega_def sup_mono d_isotone mult_left_isotone omega_isotone star.circ_isotone)

lemma star_below_Omega:
  "x⇧^⋆ ≤ x⇧^Ω"
  using Omega_def by auto

lemma one_below_Omega:
  "1 ≤ x⇧^Ω"
  using order_trans star.circ_reflexive star_below_Omega by blast

lemma L_left_zero_star:
  "L * x⇧^⋆ = L"
  by (meson L_left_zero_below order.antisym star.circ_back_loop_prefixpoint sup.boundedE)

lemma L_left_zero_Omega:
  "L * x⇧^Ω = L"
  using L_left_zero_star L_left_zero_below Omega_def mult_left_dist_sup sup.order_iff sup_monoid.add_commute by auto

lemma mult_L_star:
  "(x * L)⇧^⋆ = 1 ⊔ x * L"
  by (metis L_left_zero_star mult_assoc star.circ_left_unfold)

lemma mult_L_omega_below:
  "(x * L)⇧^ω ≤ x * L"
  by (metis L_left_zero_below mult_right_isotone omega_slide)

lemma mult_L_sup_star:
  "(x * L ⊔ y)⇧^⋆ = y⇧^⋆ ⊔ y⇧^⋆ * x * L"
  by (metis L_left_zero_star sup_commute mult_assoc star.circ_unfold_sum)

lemma mult_L_sup_omega_below:
  "(x * L ⊔ y)⇧^ω ≤ y⇧^ω ⊔ y⇧^⋆ * x * L"
proof -
  have "(x * L ⊔ y)⇧^ω = (y⇧^⋆ * x * L)⇧^ω ⊔ (y⇧^⋆ * x * L)⇧^⋆ * y⇧^ω"
    by (simp add: ils.il_inf_associative omega_decompose sup_commute)
  also have "... ≤ y⇧^⋆ * x * L ⊔ (y⇧^⋆ * x * L)⇧^⋆ * y⇧^ω"
    using sup_left_isotone mult_L_omega_below by auto
  also have "... = y⇧^⋆ * x * L ⊔ y⇧^⋆ * x * L * y⇧^ω ⊔ y⇧^ω"
    by (smt L_left_zero_star sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint)
  also have "... ≤ y⇧^ω ⊔ y⇧^⋆ * x * L"
    by (metis L_left_zero_star sup_commute eq_refl mult_assoc star.circ_back_loop_fixpoint)
  finally show ?thesis
    .
qed

lemma mult_L_sup_circ:
  "(x * L ⊔ y)⇧^Ω = d(y⇧^ω) * L ⊔ y⇧^⋆ ⊔ y⇧^⋆ * x * L"
proof -
  have "(x * L ⊔ y)⇧^Ω = d((x * L ⊔ y)⇧^ω) * L ⊔ (x * L ⊔ y)⇧^⋆"
    by (simp add: Omega_def)
  also have "... ≤ d(y⇧^ω ⊔ y⇧^⋆ * x * L) * L ⊔ (x * L ⊔ y)⇧^⋆"
    by (metis sup_left_isotone d_isotone mult_L_sup_omega_below mult_left_isotone)
  also have "... = d(y⇧^ω) * L ⊔ d(y⇧^⋆ * x * L) * L ⊔ (x * L ⊔ y)⇧^⋆"
    by (simp add: d_dist_sup mult_right_dist_sup)
  also have "... ≤ d(y⇧^ω) * L ⊔ y⇧^⋆ * x * L * L ⊔ (x * L ⊔ y)⇧^⋆"
    by (meson d_mult_L order.refl sup.mono)
  also have "... = d(y⇧^ω) * L ⊔ y⇧^⋆ ⊔ y⇧^⋆ * x * L"
    by (smt L_L sup_assoc sup_commute le_iff_sup mult_L_sup_star mult_assoc order_refl)
  finally have 1: "(x * L ⊔ y)⇧^Ω ≤ d(y⇧^ω) * L ⊔ y⇧^⋆ ⊔ y⇧^⋆ * x * L"
    .
  have 2: "d(y⇧^ω) * L ≤ (x * L ⊔ y)⇧^Ω"
    using Omega_isotone Omega_def by force
  have "y⇧^⋆ ⊔ y⇧^⋆ * x * L ≤ (x * L ⊔ y)⇧^Ω"
    by (metis Omega_def sup_ge2 mult_L_sup_star)
  hence "d(y⇧^ω) * L ⊔ y⇧^⋆ ⊔ y⇧^⋆ * x * L ≤ (x * L ⊔ y)⇧^Ω"
    using 2 by simp
  thus ?thesis
    using 1 by (simp add: order.antisym)
qed

lemma circ_sup_d:
  "(x⇧^Ω * y)⇧^Ω * x⇧^Ω = d((x⇧^⋆ * y)⇧^ω) * L ⊔ ((x⇧^⋆ * y)⇧^⋆ * x⇧^⋆ ⊔ (x⇧^⋆ * y)⇧^⋆ * d(x⇧^ω) * L)"
proof -
  have "(x⇧^Ω * y)⇧^Ω * x⇧^Ω = ((d(x⇧^ω) * L ⊔ x⇧^⋆) * y)⇧^Ω * x⇧^Ω"
    by (simp add: Omega_def)
  also have "... = (d(x⇧^ω) * L * y ⊔ x⇧^⋆ * y)⇧^Ω * x⇧^Ω"
    by (simp add: mult_right_dist_sup)
  also have "... ≤ (d(x⇧^ω) * L ⊔ x⇧^⋆ * y)⇧^Ω * x⇧^Ω"
    by (metis L_left_zero_below Omega_isotone sup_left_isotone mult_assoc mult_left_isotone mult_right_isotone)
  also have "... = (d((x⇧^⋆ * y)⇧^ω) * L ⊔ (x⇧^⋆ * y)⇧^⋆ ⊔ (x⇧^⋆ * y)⇧^⋆ * d(x⇧^ω) * L) * x⇧^Ω"
    by (simp add: mult_L_sup_circ)
  also have "... = d((x⇧^⋆ * y)⇧^ω) * L * x⇧^Ω ⊔ (x⇧^⋆ * y)⇧^⋆ * x⇧^Ω ⊔ (x⇧^⋆ * y)⇧^⋆ * d(x⇧^ω) * L * x⇧^Ω"
    using mult_right_dist_sup by auto
  also have "... = d((x⇧^⋆ * y)⇧^ω) * L ⊔ (x⇧^⋆ * y)⇧^⋆ * x⇧^Ω ⊔ (x⇧^⋆ * y)⇧^⋆ * d(x⇧^ω) * L"
    by (simp add: L_left_zero_Omega mult.assoc)
  also have "... = d((x⇧^⋆ * y)⇧^ω) * L ⊔ ((x⇧^⋆ * y)⇧^⋆ * x⇧^⋆ ⊔ (x⇧^⋆ * y)⇧^⋆ * d(x⇧^ω) * L)"
    by (simp add: Omega_def ils.il_inf_associative semiring.distrib_left sup_left_commute sup_monoid.add_commute)
  finally have 1: "(x⇧^Ω * y)⇧^Ω * x⇧^Ω ≤ d((x⇧^⋆ * y)⇧^ω) * L ⊔ ((x⇧^⋆ * y)⇧^⋆ * x⇧^⋆ ⊔ (x⇧^⋆ * y)⇧^⋆ * d(x⇧^ω) * L)"
    .
  have "d((x⇧^⋆ * y)⇧^ω) * L ≤ (x⇧^Ω * y)⇧^Ω"
    using Omega_isotone Omega_def mult_left_isotone by auto
  also have "... ≤ (x⇧^Ω * y)⇧^Ω * x⇧^Ω"
    by (metis mult_right_isotone mult_1_right one_below_Omega)
  finally have 2: "d((x⇧^⋆ * y)⇧^ω) * L ≤ (x⇧^Ω * y)⇧^Ω * x⇧^Ω"
    .
  have 3: "(x⇧^⋆ * y)⇧^⋆ * x⇧^⋆ ≤ (x⇧^Ω * y)⇧^Ω * x⇧^Ω"
    by (meson Omega_isotone order.trans mult_left_isotone mult_right_isotone star_below_Omega)
  have "(x⇧^⋆ * y)⇧^⋆ * d(x⇧^ω) * L ≤ (x⇧^⋆ * y)⇧^⋆ * x⇧^Ω"
    by (metis Omega_def sup_commute mult_assoc mult_left_sub_dist_sup_right)
  also have "... ≤ (x⇧^Ω * y)⇧^Ω * x⇧^Ω"
    using Omega_isotone Omega_def mult_left_isotone by force
  finally have "d((x⇧^⋆ * y)⇧^ω) * L ⊔ ((x⇧^⋆ * y)⇧^⋆ * x⇧^⋆ ⊔ (x⇧^⋆ * y)⇧^⋆ * d(x⇧^ω) * L) ≤ (x⇧^Ω * y)⇧^Ω * x⇧^Ω"
    using 2 3 by (simp add: sup_assoc)
  thus ?thesis
    using 1 by (simp add: order.antisym)
qed

(*
lemma mult_L_omega: "(x * L)⇧^ω = x * L" nitpick [expect=genuine,card=5] oops
lemma mult_L_sup_omega: "(x * L ⊔ y)⇧^ω = y⇧^ω ⊔ y⇧^⋆ * x * L" nitpick [expect=genuine,card=5] oops
lemma d_Omega_circ_simulate_right_plus: "z * x ≤ y * y⇧^Ω * z ⊔ w ⟹ z * x⇧^Ω ≤ y⇧^Ω * (z ⊔ w * x⇧^Ω)" nitpick [expect=genuine,card=4] oops
lemma d_Omega_circ_simulate_left_plus: "x * z ≤ z * y⇧^Ω ⊔ w ⟹ x⇧^Ω * z ≤ (z ⊔ x⇧^Ω * w) * y⇧^Ω" nitpick [expect=genuine,card=3] oops
*)

end

class ed = ed_below +
  assumes L_left_zero: "L * x = L"
begin

lemma mult_L_omega:
  "(x * L)⇧^ω = x * L"
  by (metis L_left_zero omega_slide)

lemma mult_L_sup_omega:
  "(x * L ⊔ y)⇧^ω = y⇧^ω ⊔ y⇧^⋆ * x * L"
  by (metis L_left_zero ils.il_inf_associative mult_bot_add_omega sup_commute)

lemma d_Omega_circ_simulate_right_plus:
  assumes "z * x ≤ y * y⇧^Ω * z ⊔ w"
    shows "z * x⇧^Ω ≤ y⇧^Ω * (z ⊔ w * x⇧^Ω)"
proof -
  have "z * x ≤ y * d(y⇧^ω) * L * z ⊔ y * y⇧^⋆ * z ⊔ w"
    using assms Omega_def ils.il_inf_associative mult_right_dist_sup semiring.distrib_left by auto
  also have "... ≤ y * d(y⇧^ω) * L ⊔ y * y⇧^⋆ * z ⊔ w"
    by (metis L_left_zero_below sup_commute sup_right_isotone mult_assoc mult_right_isotone)
  also have "... = y * bot ⊔ d(y * y⇧^ω) * L ⊔ y * y⇧^⋆ * z ⊔ w"
    by (simp add: d_L_split)
  also have "... = d(y⇧^ω) * L ⊔ y * y⇧^⋆ * z ⊔ w"
    by (smt sup_assoc sup_commute sup_bot_left mult_assoc mult_left_dist_sup omega_unfold)
  finally have 1: "z * x ≤ d(y⇧^ω) * L ⊔ y * y⇧^⋆ * z ⊔ w"
    .
  have "(d(y⇧^ω) * L ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * d(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆) * x = d(y⇧^ω) * L * x ⊔ y⇧^⋆ * z * x ⊔ y⇧^⋆ * w * d(x⇧^ω) * L * x ⊔ y⇧^⋆ * w * x⇧^⋆ * x"
    using mult_right_dist_sup by fastforce
  also have "... ≤ d(y⇧^ω) * L ⊔ y⇧^⋆ * z * x ⊔ y⇧^⋆ * w * d(x⇧^ω) * L * x ⊔ y⇧^⋆ * w * x⇧^⋆ * x"
    by (metis L_left_zero_below sup_left_isotone mult_assoc mult_right_isotone)
  also have "... ≤ d(y⇧^ω) * L ⊔ y⇧^⋆ * z * x ⊔ y⇧^⋆ * w * d(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆ * x"
    by (metis L_left_zero_below sup_commute sup_left_isotone mult_assoc mult_right_isotone)
  also have "... ≤ d(y⇧^ω) * L ⊔ y⇧^⋆ * z * x ⊔ y⇧^⋆ * w * d(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (meson star.circ_back_loop_prefixpoint sup.boundedE sup_right_isotone)
  also have "... ≤ d(y⇧^ω) * L ⊔ y⇧^⋆ * (d(y⇧^ω) * L ⊔ y * y⇧^⋆ * z ⊔ w) ⊔ y⇧^⋆ * w * d(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    using 1 by (smt sup_left_isotone sup_right_isotone le_iff_sup mult_assoc mult_left_dist_sup)
  also have "... = d(y⇧^ω) * L ⊔ y⇧^⋆ * y * y⇧^⋆ * z ⊔ y⇧^⋆ * w * d(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (smt sup_assoc sup_commute sup_idem mult_assoc mult_left_dist_sup d_L_split star.circ_back_loop_fixpoint star_mult_omega)
  also have "... ≤ d(y⇧^ω) * L ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * d(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    using mult_isotone order_refl semiring.add_right_mono star.circ_mult_upper_bound star.right_plus_below_circ sup_right_isotone by auto
  finally have 2: "z * x⇧^⋆ ≤ d(y⇧^ω) * L ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * d(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (smt le_sup_iff sup_ge1 star.circ_loop_fixpoint star_right_induct)
  have "z * x * x⇧^ω ≤ y * y⇧^⋆ * z * x⇧^ω ⊔ d(y⇧^ω) * L * x⇧^ω ⊔ w * x⇧^ω"
    using 1 by (metis sup_commute mult_left_isotone mult_right_dist_sup)
  also have "... ≤ y * y⇧^⋆ * z * x⇧^ω ⊔ d(y⇧^ω) * L ⊔ w * x⇧^ω"
    by (metis L_left_zero eq_refl ils.il_inf_associative)
  finally have "z * x⇧^ω ≤ y⇧^ω ⊔ y⇧^⋆ * d(y⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^ω"
    by (smt sup_assoc sup_commute left_plus_omega mult_assoc mult_left_dist_sup omega_induct omega_unfold star.left_plus_circ)
  hence "z * x⇧^ω ≤ y⇧^ω ⊔ y⇧^⋆ * w * x⇧^ω"
    by (metis sup_commute d_mult_L le_iff_sup mult_assoc mult_right_isotone omega_sub_vector order_trans star_mult_omega)
  hence "d(z * x⇧^ω) * L ≤ d(y⇧^ω) * L ⊔ y⇧^⋆ * w * d(x⇧^ω) * L"
    by (smt sup_assoc sup_commute d_L_split d_dist_sup le_iff_sup mult_right_dist_sup)
  hence "z * d(x⇧^ω) * L ≤ z * bot ⊔ d(y⇧^ω) * L ⊔ y⇧^⋆ * w * d(x⇧^ω) * L"
    using d_L_split sup_assoc sup_right_isotone by force
  also have "... ≤ y⇧^⋆ * z ⊔ d(y⇧^ω) * L ⊔ y⇧^⋆ * w * d(x⇧^ω) * L"
    by (smt sup_commute sup_left_isotone sup_ge1 order_trans star.circ_loop_fixpoint zero_right_mult_decreasing)
  finally have "z * d(x⇧^ω) * L ≤ d(y⇧^ω) * L ⊔ y⇧^⋆ * z ⊔ y⇧^⋆ * w * d(x⇧^ω) * L ⊔ y⇧^⋆ * w * x⇧^⋆"
    by (simp add: le_supI2 sup_commute)
  thus ?thesis
    using 2 by (smt L_left_zero Omega_def sup_assoc le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup)
qed

lemma d_Omega_circ_simulate_left_plus:
  assumes "x * z ≤ z * y⇧^Ω ⊔ w"
    shows "x⇧^Ω * z ≤ (z ⊔ x⇧^Ω * w) * y⇧^Ω"
proof -
  have "x * (z * d(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ d(x⇧^ω) * L ⊔ x⇧^⋆ * w * d(y⇧^ω) * L ⊔ x⇧^⋆ * w * y⇧^⋆) = x * z * d(y⇧^ω) * L ⊔ x * z * y⇧^⋆ ⊔ d(x⇧^ω) * L ⊔ x * x⇧^⋆ * w * d(y⇧^ω) * L ⊔ x * x⇧^⋆ * w * y⇧^⋆"
    by (smt sup_assoc sup_commute mult_assoc mult_left_dist_sup d_L_split omega_unfold)
  also have "... ≤ (z * d(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ w) * d(y⇧^ω) * L ⊔ (z * d(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ w) * y⇧^⋆ ⊔ d(x⇧^ω) * L ⊔ x⇧^⋆ * w * d(y⇧^ω) * L ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (smt assms Omega_def sup_assoc sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_loop_fixpoint)
  also have "... = z * d(y⇧^ω) * L ⊔ z * y⇧^⋆ * d(y⇧^ω) * L ⊔ w * d(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ w * y⇧^⋆ ⊔ d(x⇧^ω) * L ⊔ x⇧^⋆ * w * d(y⇧^ω) * L ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (smt L_left_zero sup_assoc sup_commute sup_idem mult_assoc mult_right_dist_sup star.circ_transitive_equal)
  also have "... = z * d(y⇧^ω) * L ⊔ w * d(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ w * y⇧^⋆ ⊔ d(x⇧^ω) * L ⊔ x⇧^⋆ * w * d(y⇧^ω) * L ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (smt sup_assoc sup_commute sup_idem le_iff_sup mult_assoc d_L_split star_mult_omega zero_right_mult_decreasing)
  finally have "x * (z * d(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ d(x⇧^ω) * L ⊔ x⇧^⋆ * w * d(y⇧^ω) * L ⊔ x⇧^⋆ * w * y⇧^⋆) ≤ z * d(y⇧^ω) * L ⊔ z * y⇧^⋆ ⊔ d(x⇧^ω) * L ⊔ x⇧^⋆ * w * d(y⇧^ω) * L ⊔ x⇧^⋆ * w * y⇧^⋆"
    by (smt sup_assoc sup_commute sup_idem mult_assoc star.circ_loop_fixpoint)
  thus ?thesis
    by (smt (verit, del_insts) L_left_zero Omega_def sup_assoc le_sup_iff sup_ge1 mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_back_loop_fixpoint star_left_induct)
qed

end

text ‹Theorem 2.5 and Theorem 50.4›

sublocale ed < ed_omega: itering where circ = Omega
  apply unfold_locales
  apply (smt sup_assoc sup_commute sup_bot_left circ_sup_d Omega_def mult_left_dist_sup mult_right_dist_sup d_L_split d_dist_sup omega_decompose star.circ_sup_1 star.circ_slide)
  apply (smt L_left_zero sup_assoc sup_commute sup_bot_left Omega_def mult_assoc mult_left_dist_sup mult_right_dist_sup d_L_split omega_slide star.circ_mult)
  using d_Omega_circ_simulate_right_plus apply blast
  by (simp add: d_Omega_circ_simulate_left_plus)

sublocale ed < ed_star: itering where circ = star ..

class ed_2 = ed_below + antidomain_semiring_L + Omega
begin

subclass ed
  apply unfold_locales
  by (rule L_left_zero)

end

end

Theory Relative_Domain

(* Title:      Relative Domain
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Relative Domain›

theory Relative_Domain

imports Tests

begin

class Z =
  fixes Z :: "'a"

class relative_domain_semiring = idempotent_left_semiring + dom + Z +
  assumes d_restrict : "x ≤ d(x) * x ⊔ Z"
  assumes d_mult_d   : "d(x * y) = d(x * d(y))"
  assumes d_below_one: "d(x) ≤ 1"
  assumes d_Z        : "d(Z) = bot"
  assumes d_dist_sup : "d(x ⊔ y) = d(x) ⊔ d(y)"
  assumes d_export   : "d(d(x) * y) = d(x) * d(y)"
begin

lemma d_plus_one: 
  "d(x) ⊔ 1 = 1"
  by (simp add: d_below_one sup_absorb2)

text ‹Theorem 44.2›

lemma d_zero:
  "d(bot) = bot"
  by (metis d_Z d_export mult_left_zero)

text ‹Theorem 44.3›

lemma d_involutive:
  "d(d(x)) = d(x)"
  by (metis d_mult_d mult_left_one)

lemma d_fixpoint:
  "(∃y . x = d(y)) ⟷ x = d(x)"
  using d_involutive by auto

lemma d_type:
  "∀P . (∀x . x = d(x) ⟶ P(x)) ⟷ (∀x . P(d(x)))"
  by (metis d_involutive)

text ‹Theorem 44.4›

lemma d_mult_sub:
  "d(x * y) ≤ d(x)"
  by (smt (verit, ccfv_threshold) d_plus_one d_dist_sup d_mult_d le_iff_sup mult.right_neutral mult_left_sub_dist_sup_right sup_commute)

lemma d_sub_one:
  "x ≤ 1 ⟹ x ≤ d(x) ⊔ Z"
  by (metis sup_left_isotone d_restrict mult_right_isotone mult_1_right order_trans)

lemma d_one:
  "d(1) ⊔ Z = 1 ⊔ Z"
  by (meson d_sub_one d_below_one order.trans preorder_one_closed sup.cobounded1 sup_same_context)

text ‹Theorem 44.8›

lemma d_strict:
  "d(x) = bot ⟷ x ≤ Z"
  by (metis sup_commute sup_bot_right d_Z d_dist_sup d_restrict le_iff_sup mult_left_zero)

text ‹Theorem 44.1›

lemma d_isotone:
  "x ≤ y ⟹ d(x) ≤ d(y)"
  using d_dist_sup sup_right_divisibility by force

lemma d_plus_left_upper_bound:
  "d(x) ≤ d(x ⊔ y)"
  by (simp add: d_isotone)

lemma d_idempotent:
  "d(x) * d(x) = d(x)"
  by (smt (verit, ccfv_threshold) d_involutive d_mult_sub d_Z d_dist_sup d_export d_restrict le_iff_sup sup_bot_left sup_commute)

text ‹Theorem 44.12›

lemma d_least_left_preserver:
  "x ≤ d(y) * x ⊔ Z ⟷ d(x) ≤ d(y)"
  apply (rule iffI)
  apply (smt (z3) comm_monoid.comm_neutral d_involutive d_mult_sub d_plus_left_upper_bound d_Z d_dist_sup order_trans sup_absorb2 sup_bot.comm_monoid_axioms)
  by (smt (verit, del_insts) d_restrict mult_right_dist_sup sup.cobounded1 sup.orderE sup_assoc sup_commute)

text ‹Theorem 44.9›

lemma d_weak_locality:
  "x * y ≤ Z ⟷ x * d(y) ≤ Z"
  by (metis d_mult_d d_strict)

lemma d_sup_closed:
  "d(d(x) ⊔ d(y)) = d(x) ⊔ d(y)"
  by (simp add: d_involutive d_dist_sup)

lemma d_mult_closed:
  "d(d(x) * d(y)) = d(x) * d(y)"
  using d_export d_mult_d by auto

lemma d_mult_left_lower_bound:
  "d(x) * d(y) ≤ d(x)"
  by (metis d_export d_involutive d_mult_sub)

lemma d_mult_left_absorb_sup:
  "d(x) * (d(x) ⊔ d(y)) = d(x)"
  by (smt d_sup_closed d_export d_idempotent d_involutive d_mult_sub order.eq_iff mult_left_sub_dist_sup_left)

lemma d_sup_left_absorb_mult:
  "d(x) ⊔ d(x) * d(y) = d(x)"
  using d_mult_left_lower_bound sup.absorb_iff1 by auto

lemma d_commutative:
  "d(x) * d(y) = d(y) * d(x)"
  by (metis sup_commute order.antisym d_sup_left_absorb_mult d_below_one d_export d_mult_left_absorb_sup mult_assoc mult_left_isotone mult_left_one)

lemma d_mult_greatest_lower_bound:
  "d(x) ≤ d(y) * d(z) ⟷ d(x) ≤ d(y) ∧ d(x) ≤ d(z)"
  by (metis d_commutative d_idempotent d_mult_left_lower_bound mult_isotone order_trans)

lemma d_sup_left_dist_mult:
  "d(x) ⊔ d(y) * d(z) = (d(x) ⊔ d(y)) * (d(x) ⊔ d(z))"
  by (metis sup_assoc d_commutative d_dist_sup d_idempotent d_mult_left_absorb_sup mult_right_dist_sup)

lemma d_order:
  "d(x) ≤ d(y) ⟷ d(x) = d(x) * d(y)"
  by (metis d_mult_greatest_lower_bound d_mult_left_absorb_sup le_iff_sup order_refl)

text ‹Theorem 44.6›

lemma Z_mult_decreasing:
  "Z * x ≤ Z"
  by (metis d_mult_sub bot.extremum d_strict order.eq_iff)

text ‹Theorem 44.5›

lemma d_below_d_one:
  "d(x) ≤ d(1)"
  by (metis d_mult_sub mult_left_one)

text ‹Theorem 44.7›

lemma d_relative_Z:
  "d(x) * x ⊔ Z = x ⊔ Z"
  by (metis sup_ge1 sup_same_context d_below_one d_restrict mult_isotone mult_left_one)

lemma Z_left_zero_above_one:
  "1 ≤ x ⟹ Z * x = Z"
  by (metis Z_mult_decreasing order.eq_iff mult_right_isotone mult_1_right)

text ‹Theorem 44.11›

lemma kat_4:
  "d(x) * y = d(x) * y * d(z) ⟹ d(x) * y ≤ y * d(z)"
  by (metis d_below_one mult_left_isotone mult_left_one)

lemma kat_4_equiv:
  "d(x) * y = d(x) * y * d(z) ⟷ d(x) * y ≤ y * d(z)"
  apply (rule iffI)
  apply (simp add: kat_4)
  apply (rule order.antisym)
  apply (metis d_idempotent mult_assoc mult_right_isotone)
  by (metis d_below_one mult_right_isotone mult_1_right)

lemma kat_4_equiv_opp:
  "y * d(x) = d(z) * y * d(x) ⟷ y * d(x) ≤ d(z) * y"
  apply (rule iffI)
  using d_below_one mult_right_isotone apply fastforce
  apply (rule order.antisym)
  apply (metis d_idempotent mult_assoc mult_left_isotone)
  by (metis d_below_one mult_left_isotone mult_left_one)

text ‹Theorem 44.10›

lemma d_restrict_iff_1:
  "d(x) * y ≤ z ⟷ d(x) * y ≤ d(x) * z"
  by (smt (verit, del_insts) d_below_one d_idempotent mult_assoc mult_left_isotone mult_left_one mult_right_isotone order_trans)

(* independence of axioms, checked in relative_domain_semiring without the respective axiom:
lemma d_restrict : "x ≤ d(x) * x ⊔ Z" nitpick [expect=genuine,card=2] oops
lemma d_mult_d   : "d(x * y) = d(x * d(y))" nitpick [expect=genuine,card=3] oops
lemma d_below_one: "d(x) ≤ 1" nitpick [expect=genuine,card=3] oops
lemma d_Z        : "d(Z) = bot" nitpick [expect=genuine,card=2] oops
lemma d_dist_sup : "d(x ⊔ y) = d(x) ⊔ d(y)" nitpick [expect=genuine,card=3] oops
lemma d_export   : "d(d(x) * y) = d(x) * d(y)" nitpick [expect=genuine,card=5] oops
*)

end

typedef (overloaded) 'a dImage = "{ x::'a::relative_domain_semiring . (∃y::'a . x = d(y)) }"
  by auto

lemma simp_dImage[simp]:
  "∃y . Rep_dImage x = d(y)"
  using Rep_dImage by simp

setup_lifting type_definition_dImage

text ‹Theorem 44›

instantiation dImage :: (relative_domain_semiring) bounded_distrib_lattice
begin

lift_definition sup_dImage :: "'a dImage ⇒ 'a dImage ⇒ 'a dImage" is sup
  by (metis d_dist_sup)

lift_definition inf_dImage :: "'a dImage ⇒ 'a dImage ⇒ 'a dImage" is times
  by (metis d_export)

lift_definition bot_dImage :: "'a dImage" is bot
  by (metis d_zero)

lift_definition top_dImage :: "'a dImage" is "d(1)"
  by auto

lift_definition less_eq_dImage :: "'a dImage ⇒ 'a dImage ⇒ bool" is less_eq .

lift_definition less_dImage :: "'a dImage ⇒ 'a dImage ⇒ bool" is less .

instance
  apply intro_classes
  apply (simp add: less_dImage.rep_eq less_eq_dImage.rep_eq less_le_not_le)
  apply (simp add: less_eq_dImage.rep_eq)
  using less_eq_dImage.rep_eq apply simp
  apply (simp add: Rep_dImage_inject less_eq_dImage.rep_eq)
  apply (metis (mono_tags) d_involutive d_mult_sub inf_dImage.rep_eq less_eq_dImage.rep_eq simp_dImage)
  apply (metis (mono_tags) d_mult_greatest_lower_bound inf_dImage.rep_eq less_eq_dImage.rep_eq order_refl simp_dImage)
  apply (metis (mono_tags) d_mult_greatest_lower_bound inf_dImage.rep_eq less_eq_dImage.rep_eq simp_dImage)
  apply (simp add: less_eq_dImage.rep_eq sup_dImage.rep_eq)
  apply (simp add: less_eq_dImage.rep_eq sup_dImage.rep_eq)
  apply (simp add: less_eq_dImage.rep_eq sup_dImage.rep_eq)
  apply (simp add: bot_dImage.rep_eq less_eq_dImage.rep_eq)
  apply (smt (z3) d_below_d_one less_eq_dImage.rep_eq simp_dImage top_dImage.rep_eq)
  by (smt (z3) inf_dImage.rep_eq sup_dImage.rep_eq simp_dImage Rep_dImage_inject d_sup_left_dist_mult)

end

class bounded_relative_domain_semiring = relative_domain_semiring + bounded_idempotent_left_semiring
begin

lemma Z_top:
  "Z * top = Z"
  by (simp add: Z_left_zero_above_one)

lemma d_restrict_top:
  "x ≤ d(x) * top ⊔ Z"
  by (metis sup_left_isotone d_restrict mult_right_isotone order_trans top_greatest)

(*
lemma d_one_one: "d(1) = 1" nitpick [expect=genuine,card=2] oops
*)

end

class relative_domain_semiring_split = relative_domain_semiring +
  assumes split_Z: "x * (y ⊔ Z) ≤ x * y ⊔ Z"
begin

lemma d_restrict_iff:
  "(x ≤ y ⊔ Z) ⟷ (x ≤ d(x) * y ⊔ Z)"
proof -
  have "x ≤ y ⊔ Z ⟶ x ≤ d(x) * (y ⊔ Z) ⊔ Z"
    by (smt sup_left_isotone d_restrict le_iff_sup mult_left_sub_dist_sup_left order_trans)
  hence "x ≤ y ⊔ Z ⟶ x ≤ d(x) * y ⊔ Z"
    by (meson le_supI order_lesseq_imp split_Z sup.cobounded2)
  thus ?thesis
    by (meson d_restrict_iff_1 le_supI mult_left_sub_dist_sup_left order_lesseq_imp sup.cobounded2)
qed

end

class relative_antidomain_semiring = idempotent_left_semiring + dom + Z + uminus +
  assumes a_restrict  : "-x * x ≤ Z"
  assumes a_mult_d    : "-(x * y) = -(x * --y)"
  assumes a_complement: "-x * --x = bot"
  assumes a_Z         : "-Z = 1"
  assumes a_export    : "-(--x * y) = -x ⊔ -y"
  assumes a_dist_sup  : "-(x ⊔ y) = -x * -y"
  assumes d_def       : "d(x) = --x"
begin

notation
  uminus ("a")

text ‹Theorem 45.7›

lemma a_complement_one:
  "--x ⊔ -x = 1"
  by (metis a_Z a_complement a_export a_mult_d mult_left_one)

text ‹Theorem 45.5 and Theorem 45.6›

lemma a_d_closed:
  "d(a(x)) = a(x)"
  by (metis a_mult_d d_def mult_left_one)

lemma a_below_one:
  "a(x) ≤ 1"
  using a_complement_one sup_right_divisibility by auto

lemma a_export_a:
  "a(a(x) * y) = d(x) ⊔ a(y)"
  by (metis a_d_closed a_export d_def)

lemma a_sup_absorb:
  "(x ⊔ a(y)) * a(a(y)) = x * a(a(y))"
  by (simp add: a_complement mult_right_dist_sup)

text ‹Theorem 45.10›

lemma a_greatest_left_absorber:
  "a(x) * y ≤ Z ⟷ a(x) ≤ a(y)"
  apply (rule iffI)
  apply (smt a_Z a_sup_absorb a_dist_sup a_export_a a_mult_d sup_commute d_def le_iff_sup mult_left_one)
  by (meson a_restrict mult_isotone order.refl order_trans)

lemma a_plus_left_lower_bound:
  "a(x ⊔ y) ≤ a(x)"
  by (metis a_greatest_left_absorber a_restrict sup_commute mult_left_sub_dist_sup_right order_trans)

text ‹Theorem 45.2›

subclass relative_domain_semiring
  apply unfold_locales
  apply (smt (verit) a_Z a_complement_one a_restrict sup_commute sup_ge1 case_split_left d_def order_trans)
  using a_mult_d d_def apply force
  apply (simp add: a_below_one d_def)
  apply (metis a_Z a_complement d_def mult_left_one)
  apply (simp add: a_export_a a_dist_sup d_def)
  using a_dist_sup a_export d_def by auto

text ‹Theorem 45.1›

subclass tests
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (metis a_dist_sup sup_commute)
  apply (smt a_complement a_d_closed a_export_a sup_bot_right d_sup_left_dist_mult)
  apply (metis a_d_closed a_dist_sup d_def)
  apply (rule the_equality[THEN sym])
  apply (simp add: a_complement)
  apply (simp add: a_complement)
  using a_d_closed a_Z d_Z d_def apply force
  using a_export a_mult_d apply fastforce
  apply (metis a_d_closed d_order)
  by (simp add: less_le_not_le)

lemma a_plus_mult_d:
  "-(x * y) ⊔ -(x * --y) = -(x * --y)"
  using a_mult_d by auto

lemma a_mult_d_2:
  "a(x * y) = a(x * d(y))"
  using a_mult_d d_def by auto

lemma a_3:
  "a(x) * a(y) * d(x ⊔ y) = bot"
  by (metis a_complement a_dist_sup d_def)

lemma a_fixpoint:
  "∀x . (a(x) = x ⟶ (∀y . y = bot))"
  by (metis a_complement_one mult_1_left mult_left_zero order.refl sup.order_iff tests_dual.one_def)

text ‹Theorem 45.9›

lemma a_strict:
  "a(x) = 1 ⟷ x ≤ Z"
  by (metis a_Z d_def d_strict order.refl tests_dual.sba_dual.double_negation)

lemma d_complement_zero:
  "d(x) * a(x) = bot"
  by (simp add: d_def tests_dual.sub_commutative)

lemma a_complement_zero:
  "a(x) * d(x) = bot"
  by (simp add: d_def)

lemma a_shunting_zero:
  "a(x) * d(y) = bot ⟷ a(x) ≤ a(y)"
  by (simp add: d_def tests_dual.sba_dual.less_eq_inf_bot)

lemma a_antitone:
  "x ≤ y ⟹ a(y) ≤ a(x)"
  using a_plus_left_lower_bound sup_commute sup_right_divisibility by fastforce

lemma a_mult_deMorgan:
  "a(a(x) * a(y)) = d(x ⊔ y)"
  by (simp add: a_dist_sup d_def)

lemma a_mult_deMorgan_1:
  "a(a(x) * a(y)) = d(x) ⊔ d(y)"
  by (simp add: a_mult_deMorgan d_dist_sup)

lemma a_mult_deMorgan_2:
  "a(d(x) * d(y)) = a(x) ⊔ a(y)"
  using a_export d_def by auto

lemma a_plus_deMorgan:
  "a(a(x) ⊔ a(y)) = d(x) * d(y)"
  by (simp add: a_dist_sup d_def)

lemma a_plus_deMorgan_1:
  "a(d(x) ⊔ d(y)) = a(x) * a(y)"
  by (simp add: a_dist_sup d_def)

text ‹Theorem 45.8›

lemma a_mult_left_upper_bound:
  "a(x) ≤ a(x * y)"
  using a_shunting_zero d_def d_mult_sub tests_dual.less_eq_sup_top by auto

text ‹Theorem 45.6›

lemma d_a_closed:
  "a(d(x)) = a(x)"
  by (simp add: d_def)

lemma a_export_d:
  "a(d(x) * y) = a(x) ⊔ a(y)"
  by (simp add: a_export d_def)

lemma a_7:
  "d(x) * a(d(y) ⊔ d(z)) = d(x) * a(y) * a(z)"
  by (simp add: a_plus_deMorgan_1 mult_assoc)

lemma d_a_shunting:
  "d(x) * a(y) ≤ d(z) ⟷ d(x) ≤ d(z) ⊔ d(y)"
  by (simp add: d_def tests_dual.sba_dual.shunting_right)

lemma d_d_shunting:
  "d(x) * d(y) ≤ d(z) ⟷ d(x) ≤ d(z) ⊔ a(y)"
  by (simp add: d_def tests_dual.sba_dual.shunting_right)

lemma d_cancellation_1:
  "d(x) ≤ d(y) ⊔ (d(x) * a(y))"
  by (smt (z3) a_d_closed d_a_shunting d_export eq_refl sup_commute)

lemma d_cancellation_2:
  "(d(z) ⊔ d(y)) * a(y) ≤ d(z)"
  by (metis d_a_shunting d_dist_sup eq_refl)

lemma a_sup_closed:
  "d(a(x) ⊔ a(y)) = a(x) ⊔ a(y)"
  using a_mult_deMorgan tests_dual.sub_inf_def by auto

lemma a_mult_closed:
  "d(a(x) * a(y)) = a(x) * a(y)"
  using d_def tests_dual.sub_sup_closed by auto

lemma d_a_shunting_zero:
  "d(x) * a(y) = bot ⟷ d(x) ≤ d(y)"
  using a_shunting_zero d_def by force

lemma d_d_shunting_zero:
  "d(x) * d(y) = bot ⟷ d(x) ≤ a(y)"
  using d_a_shunting_zero d_def by auto

lemma d_compl_intro:
  "d(x) ⊔ d(y) = d(x) ⊔ a(x) * d(y)"
  by (simp add: d_def tests_dual.sba_dual.sup_complement_intro)

lemma a_compl_intro:
  "a(x) ⊔ a(y) = a(x) ⊔ d(x) * a(y)"
  by (simp add: d_def tests_dual.sba_dual.sup_complement_intro)

lemma kat_2:
  "y * a(z) ≤ a(x) * y ⟹ d(x) * y * a(z) = bot"
  by (metis d_complement_zero order.eq_iff mult_assoc mult_left_zero mult_right_isotone bot_least)

text ‹Theorem 45.4›

lemma kat_2_equiv:
  "y * a(z) ≤ a(x) * y ⟷ d(x) * y * a(z) = bot"
  apply (rule iffI)
  apply (simp add: kat_2)
  by (smt (verit, best) a_Z a_below_one a_complement_one case_split_left d_def mult_assoc mult_right_isotone mult_1_right bot_least)

lemma kat_3_equiv_opp:
  "a(z) * y * d(x) = bot ⟷ y * d(x) = d(z) * y * d(x)"
  using kat_2_equiv d_def kat_4_equiv_opp by auto

text ‹Theorem 45.4›

lemma kat_3_equiv_opp_2:
  "d(z) * y * a(x) = bot ⟷ y * a(x) = a(z) * y * a(x)"
  by (metis a_d_closed kat_3_equiv_opp d_def)

lemma kat_equiv_6:
  "d(x) * y * a(z) = d(x) * y * bot ⟷ d(x) * y * a(z) ≤ y * bot"
  by (metis d_restrict_iff_1 order.eq_iff mult_left_sub_dist_sup_right tests_dual.sba_dual.sup_right_unit mult_assoc)

lemma d_one_one:
  "d(1) = 1"
  by (simp add: d_def)

lemma case_split_left_sup:
  "-p * x ≤ y ∧ --p * x ≤ z ⟹ x ≤ y ⊔ z"
  by (smt (z3) a_complement_one case_split_left order_lesseq_imp sup.cobounded2 sup_ge1)

lemma test_mult_left_sub_dist_shunt:
  "-p * (--p * x ⊔ Z) ≤ Z"
  by (simp add: a_greatest_left_absorber a_Z a_dist_sup a_export)

lemma test_mult_left_dist_shunt:
  "-p * (--p * x ⊔ Z) = -p * Z"
  by (smt (verit, ccfv_SIG) order.antisym mult_left_sub_dist_sup_right sup.orderE tests_dual.sba_dual.sup_idempotent mult_assoc test_mult_left_sub_dist_shunt tests_dual.sup_absorb)

(* independence of axioms, checked in relative_antidomain_semiring without the respective axiom:
lemma a_restrict  : "-x * x ≤ Z" nitpick [expect=genuine,card=3] oops
lemma a_mult_d    : "-(x * y) = -(x * --y)" nitpick [expect=genuine,card=3] oops
lemma a_complement: "-x * --x = bot" nitpick [expect=genuine,card=2] oops
lemma a_Z         : "-Z = 1" nitpick [expect=genuine,card=2] oops
lemma a_export    : "-(--x * y) = -x ⊔ -y" nitpick [expect=genuine,card=5] oops
lemma a_dist_sup  : "-(x ⊔ y) = -x * -y" nitpick [expect=genuine,card=3] oops
lemma d_def       : "d(x) = --x" nitpick [expect=genuine,card=2] oops
*)

end

typedef (overloaded) 'a aImage = "{ x::'a::relative_antidomain_semiring . (∃y::'a . x = a(y)) }"
  by auto

lemma simp_aImage[simp]:
  "∃y . Rep_aImage x = a(y)"
  using Rep_aImage by simp

setup_lifting type_definition_aImage

text ‹Theorem 45.3›

instantiation aImage :: (relative_antidomain_semiring) boolean_algebra
begin

lift_definition sup_aImage :: "'a aImage ⇒ 'a aImage ⇒ 'a aImage" is sup
  using tests_dual.sba_dual.sba_dual.inf_closed by auto

lift_definition inf_aImage :: "'a aImage ⇒ 'a aImage ⇒ 'a aImage" is times
  using tests_dual.sba_dual.inf_closed by auto

lift_definition minus_aImage :: "'a aImage ⇒ 'a aImage ⇒ 'a aImage" is "λx y . x * a(y)"
  using tests_dual.sba_dual.inf_closed by blast

lift_definition uminus_aImage :: "'a aImage ⇒ 'a aImage" is a
  by auto

lift_definition bot_aImage :: "'a aImage" is bot
  by (metis tests_dual.sba_dual.sba_dual.complement_bot)

lift_definition top_aImage :: "'a aImage" is 1
  using a_Z by auto

lift_definition less_eq_aImage :: "'a aImage ⇒ 'a aImage ⇒ bool" is less_eq .

lift_definition less_aImage :: "'a aImage ⇒ 'a aImage ⇒ bool" is less .

instance
  apply intro_classes
  apply (simp add: less_aImage.rep_eq less_eq_aImage.rep_eq less_le_not_le)
  apply (simp add: less_eq_aImage.rep_eq)
  using less_eq_aImage.rep_eq apply simp
  apply (simp add: Rep_aImage_inject less_eq_aImage.rep_eq)
  apply (metis (mono_tags) a_below_one inf_aImage.rep_eq less_eq_aImage.rep_eq mult.right_neutral mult_right_isotone simp_aImage)
  apply (metis (mono_tags, lifting) less_eq_aImage.rep_eq a_d_closed a_export bot.extremum_unique inf_aImage.rep_eq kat_equiv_6 mult.assoc mult.left_neutral mult_left_isotone mult_left_zero simp_aImage sup.cobounded1 tests_dual.sba_dual.sba_dual.complement_top)
  apply (smt (z3) less_eq_aImage.rep_eq inf_aImage.rep_eq mult_isotone simp_aImage tests_dual.sba_dual.inf_idempotent)
  apply (simp add: less_eq_aImage.rep_eq sup_aImage.rep_eq)
  apply (simp add: less_eq_aImage.rep_eq sup_aImage.rep_eq)
  using less_eq_aImage.rep_eq sup_aImage.rep_eq apply force
  apply (simp add: less_eq_aImage.rep_eq bot_aImage.rep_eq)
  apply (smt (z3) less_eq_aImage.rep_eq a_below_one simp_aImage top_aImage.rep_eq)
  apply (metis (mono_tags, lifting) tests_dual.sba_dual.sba_dual.inf_left_dist_sup Rep_aImage_inject inf_aImage.rep_eq sup_aImage.rep_eq simp_aImage)
  apply (smt (z3) inf_aImage.rep_eq uminus_aImage.rep_eq Rep_aImage_inject a_complement bot_aImage.rep_eq simp_aImage)
  apply (smt (z3) top_aImage.rep_eq Rep_aImage_inject a_complement_one simp_aImage sup_aImage.rep_eq sup_commute uminus_aImage.rep_eq)
  by (metis (mono_tags) inf_aImage.rep_eq Rep_aImage_inject minus_aImage.rep_eq uminus_aImage.rep_eq)

end

class bounded_relative_antidomain_semiring = relative_antidomain_semiring + bounded_idempotent_left_semiring
begin

subclass bounded_relative_domain_semiring ..

lemma a_top:
  "a(top) = bot"
  by (metis a_plus_left_lower_bound bot_unique sup_right_top tests_dual.sba_dual.complement_top)

lemma d_top:
  "d(top) = 1"
  using a_top d_def by auto

lemma shunting_top_1:
  "-p * x ≤ y ⟹ x ≤ --p * top ⊔ y"
  by (metis sup_commute case_split_left_sup mult_right_isotone top_greatest)

lemma shunting_Z:
  "-p * x ≤ Z ⟷ x ≤ --p * top ⊔ Z"
  apply (rule iffI)
  apply (simp add: shunting_top_1)
  by (smt a_top a_Z a_antitone a_dist_sup a_export a_greatest_left_absorber sup_commute sup_bot_right mult_left_one)

(*
lemma a_left_dist_sup: "-p * (y ⊔ z) = -p * y ⊔ -p * z" nitpick [expect=genuine,card=7] oops
lemma shunting_top: "-p * x ≤ y ⟷ x ≤ --p * top ⊔ y" nitpick [expect=genuine,card=7] oops
*)

end

class relative_left_zero_antidomain_semiring = relative_antidomain_semiring + idempotent_left_zero_semiring
begin

lemma kat_3:
  "d(x) * y * a(z) = bot ⟹ d(x) * y = d(x) * y * d(z)"
  by (metis d_def mult_1_right mult_left_dist_sup sup_monoid.add_0_left tests_dual.inf_complement)

lemma a_a_below:
  "a(a(x)) * y ≤ y"
  using d_def d_restrict_iff_1 by auto

lemma kat_equiv_5:
  "d(x) * y ≤ y * d(z) ⟷ d(x) * y * a(z) = d(x) * y * bot"
proof
  assume "d(x) * y ≤ y * d(z)"
  thus "d(x) * y * a(z) = d(x) * y * bot"
    by (metis d_complement_zero kat_4_equiv mult_assoc)
next
  assume "d(x) * y * a(z) = d(x) * y * bot"
  hence "a(a(x)) * y * a(z) ≤ y * a(a(z))"
    by (simp add: a_a_below d_def mult_isotone)
  thus "d(x) * y ≤ y * d(z)"
    by (metis a_a_below a_complement_one case_split_right d_def mult_isotone order_refl)
qed

lemma case_split_right_sup:
  "x * -p ≤ y ⟹ x * --p ≤ z ⟹ x ≤ y ⊔ z"
  by (smt (verit, ccfv_SIG) a_complement_one order.trans mult_1_right mult_left_dist_sup sup_commute sup_right_isotone)

end

class bounded_relative_left_zero_antidomain_semiring = relative_left_zero_antidomain_semiring + bounded_idempotent_left_zero_semiring
begin

lemma shunting_top:
  "-p * x ≤ y ⟷ x ≤ --p * top ⊔ y"
  apply (rule iffI)
  apply (metis sup_commute case_split_left_sup mult_right_isotone top_greatest)
  by (metis a_complement sup_bot_left sup_right_divisibility mult_assoc mult_left_dist_sup mult_left_one mult_left_zero mult_right_dist_sup mult_right_isotone order_trans tests_dual.inf_left_unit)

end

end

Theory Relative_Modal

(* Title:      Relative Modal Operators
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Relative Modal Operators›

theory Relative_Modal

imports Relative_Domain

begin

class relative_diamond_semiring = relative_domain_semiring + diamond +
  assumes diamond_def: "|x>y = d(x * y)"
begin

lemma diamond_x_1:
  "|x>1 = d(x)"
  by (simp add: diamond_def)

lemma diamond_x_d:
  "|x>d(y) = d(x * y)"
  using d_mult_d diamond_def by auto

lemma diamond_x_und:
  "|x>d(y) = |x>y"
  using diamond_x_d diamond_def by auto

lemma diamond_d_closed:
  "|x>y = d( |x>y)"
  by (simp add: d_involutive diamond_def)

text ‹Theorem 46.11›

lemma diamond_bot_y:
  "|bot>y = bot"
  by (simp add: d_zero diamond_def)

lemma diamond_1_y:
  "|1>y = d(y)"
  by (simp add: diamond_def)

text ‹Theorem 46.12›

lemma diamond_1_d:
  "|1>d(y) = d(y)"
  by (simp add: diamond_1_y diamond_x_und)

text ‹Theorem 46.10›

lemma diamond_d_y:
  "|d(x)>y = d(x) * d(y)"
  by (simp add: d_export diamond_def)

text ‹Theorem 46.11›

lemma diamond_d_bot:
  "|d(x)>bot = bot"
  by (metis diamond_bot_y diamond_d_y d_commutative d_zero)

text ‹Theorem 46.12›

lemma diamond_d_1:
  "|d(x)>1 = d(x)"
  by (simp add: diamond_x_1 d_involutive)

lemma diamond_d_d:
  "|d(x)>d(y) = d(x) * d(y)"
  by (simp add: diamond_d_y diamond_x_und)

text ‹Theorem 46.12›

lemma diamond_d_d_same:
  "|d(x)>d(x) = d(x)"
  by (simp add: diamond_d_d d_idempotent)

text ‹Theorem 46.2›

lemma diamond_left_dist_sup:
  "|x ⊔ y>z = |x>z ⊔ |y>z"
  by (simp add: d_dist_sup diamond_def mult_right_dist_sup)

text ‹Theorem 46.3›

lemma diamond_right_sub_dist_sup:
  "|x>y ⊔ |x>z ≤ |x>(y ⊔ z)"
  by (metis d_dist_sup diamond_def le_iff_sup mult_left_sub_dist_sup)

text ‹Theorem 46.4›

lemma diamond_associative:
  "|x * y>z = |x>(y * z)"
  by (simp add: diamond_def mult_assoc)

text ‹Theorem 46.4›

lemma diamond_left_mult:
  "|x * y>z = |x>|y>z"
  using diamond_x_und diamond_def mult_assoc by auto

lemma diamond_right_mult:
  "|x>(y * z) = |x>|y>z"
  using diamond_associative diamond_left_mult by auto

text ‹Theorem 46.6›

lemma diamond_d_export:
  "|d(x) * y>z = d(x) * |y>z"
  using diamond_d_y diamond_def mult_assoc by auto

lemma diamond_diamond_export:
  "||x>y>z = |x>y * |z>1"
  using diamond_d_y diamond_def by force

text ‹Theorem 46.1›

lemma diamond_left_isotone:
  "x ≤ y ⟹ |x>z ≤ |y>z"
  by (metis diamond_left_dist_sup le_iff_sup)

text ‹Theorem 46.1›

lemma diamond_right_isotone:
  "y ≤ z ⟹ |x>y ≤ |x>z"
  by (metis diamond_right_sub_dist_sup le_iff_sup le_sup_iff)

lemma diamond_isotone:
  "w ≤ y ⟹ x ≤ z ⟹ |w>x ≤ |y>z"
  by (meson diamond_left_isotone diamond_right_isotone order_trans)

lemma diamond_left_upper_bound:
  "|x>y ≤ |x ⊔ z>y"
  by (simp add: diamond_left_isotone)

lemma diamond_right_upper_bound:
  "|x>y ≤ |x>(y ⊔ z)"
  by (simp add: diamond_right_isotone)

lemma diamond_lower_bound_right:
  "|x>(d(y) * d(z)) ≤ |x>d(y)"
  by (simp add: diamond_right_isotone d_mult_left_lower_bound)

lemma diamond_lower_bound_left:
  "|x>(d(y) * d(z)) ≤ |x>d(z)"
  using diamond_lower_bound_right d_commutative by force

text ‹Theorem 46.5›

lemma diamond_right_sub_dist_mult:
  "|x>(d(y) * d(z)) ≤ |x>d(y) * |x>d(z)"
  using diamond_lower_bound_left diamond_lower_bound_right d_mult_greatest_lower_bound diamond_def by force

text ‹Theorem 46.13›

lemma diamond_demodalisation_1:
  "d(x) * |y>z ≤ Z ⟷ d(x) * y * d(z) ≤ Z"
  by (metis d_weak_locality diamond_def mult_assoc)

text ‹Theorem 46.14›

lemma diamond_demodalisation_3:
  "|x>y ≤ d(z) ⟷ x * d(y) ≤ d(z) * x ⊔ Z"
  apply (rule iffI)
  apply (smt (verit) sup_commute sup_right_isotone d_below_one d_restrict diamond_def diamond_x_und mult_left_isotone mult_right_isotone mult_1_right order_trans)
  by (smt sup_commute sup_bot_left d_Z d_commutative d_dist_sup d_involutive d_mult_sub d_plus_left_upper_bound diamond_d_y diamond_def diamond_x_und le_iff_sup order_trans)

text ‹Theorem 46.6›

lemma diamond_d_export_2:
  "|d(x) * y>z = d(x) * |d(x) * y>z"
  by (metis diamond_d_export diamond_left_mult d_idempotent)

text ‹Theorem 46.7›

lemma diamond_d_promote:
  "|x * d(y)>z = |x * d(y)>(d(y) * z)"
  by (metis d_idempotent diamond_def mult_assoc)

text ‹Theorem 46.8›

lemma diamond_d_import_iff:
  "d(x) ≤ |y>z ⟷ d(x) ≤ |d(x) * y>z"
  by (metis diamond_d_export diamond_d_y d_order diamond_def order.eq_iff)

text ‹Theorem 46.9›

lemma diamond_d_import_iff_2:
  "d(x) * d(y) ≤ |z>w ⟷ d(x) * d(y) ≤ |d(y) * z>w"
  apply (rule iffI)
  apply (metis diamond_associative d_export d_mult_greatest_lower_bound diamond_def order.refl)
  by (metis diamond_d_y d_mult_greatest_lower_bound diamond_def mult_assoc)

end

class relative_box_semiring = relative_diamond_semiring + relative_antidomain_semiring + box +
  assumes box_def: "|x]y = a(x * a(y))"
begin

text ‹Theorem 47.1›

lemma box_diamond:
  "|x]y = a( |x>a(y))"
  by (simp add: box_def d_a_closed diamond_def)

text ‹Theorem 47.2›

lemma diamond_box:
  "|x>y = a( |x]a(y))"
  using box_def d_def d_mult_d diamond_def by auto

lemma box_x_bot:
  "|x]bot = a(x)"
  by (metis box_def mult_1_right one_def)

lemma box_x_1:
  "|x]1 = a(x * bot)"
  by (simp add: box_def)

lemma box_x_d:
  "|x]d(y) = a(x * a(y))"
  by (simp add: box_def d_a_closed)

lemma box_x_und:
  "|x]d(y) = |x]y"
  by (simp add: box_diamond d_a_closed)

lemma box_x_a:
  "|x]a(y) = a(x * y)"
  using a_mult_d box_def by auto

text ‹Theorem 47.15›

lemma box_bot_y:
  "|bot]y = 1"
  using box_def by auto

lemma box_1_y:
  "|1]y = d(y)"
  by (simp add: box_def d_def)

text ‹Theorem 47.16›

lemma box_1_d:
  "|1]d(y) = d(y)"
  by (simp add: box_1_y box_x_und)

lemma box_1_a:
  "|1]a(y) = a(y)"
  by (simp add: box_x_a)

lemma box_d_y:
  "|d(x)]y = a(x) ⊔ d(y)"
  using a_export_a box_def d_def by auto

lemma box_a_y:
  "|a(x)]y = d(x) ⊔ d(y)"
  by (simp add: a_mult_deMorgan_1 box_def)

text ‹Theorem 47.14›

lemma box_d_bot:
  "|d(x)]bot = a(x)"
  by (simp add: box_x_bot d_a_closed)

lemma box_a_bot:
  "|a(x)]bot = d(x)"
  by (simp add: box_x_bot d_def)

text ‹Theorem 47.15›

lemma box_d_1:
  "|d(x)]1 = 1"
  by (simp add: box_d_y d_one_one)

lemma box_a_1:
  "|a(x)]1 = 1"
  by (simp add: box_x_1)

text ‹Theorem 47.13›

lemma box_d_d:
  "|d(x)]d(y) = a(x) ⊔ d(y)"
  by (simp add: box_d_y box_x_und)

lemma box_a_d:
  "|a(x)]d(y) = d(x) ⊔ d(y)"
  by (simp add: box_a_y box_x_und)

lemma box_d_a:
  "|d(x)]a(y) = a(x) ⊔ a(y)"
  by (simp add: box_x_a a_export_d)

lemma box_a_a:
  "|a(x)]a(y) = d(x) ⊔ a(y)"
  by (simp add: box_a_y a_d_closed)

text ‹Theorem 47.15›

lemma box_d_d_same:
  "|d(x)]d(x) = 1"
  using box_x_d d_complement_zero by auto

lemma box_a_a_same:
  "|a(x)]a(x) = 1"
  by (simp add: box_def)

text ‹Theorem 47.16›

lemma box_d_below_box:
  "d(x) ≤ |d(y)]d(x)"
  by (simp add: box_d_d)

lemma box_d_closed:
  "|x]y = d( |x]y)"
  by (simp add: a_d_closed box_def)

lemma box_deMorgan_1:
  "a( |x]y) = |x>a(y)"
  by (simp add: diamond_box box_def)

lemma box_deMorgan_2:
  "a( |x>y) = |x]a(y)"
  using box_x_a d_a_closed diamond_def by auto

text ‹Theorem 47.5›

lemma box_left_dist_sup:
  "|x ⊔ y]z = |x]z * |y]z"
  by (simp add: a_dist_sup box_def mult_right_dist_sup)

lemma box_right_dist_sup:
  "|x](y ⊔ z) = a(x * a(y) * a(z))"
  by (simp add: a_dist_sup box_def mult_assoc)

lemma box_associative:
  "|x * y]z = a(x * y * a(z))"
  by (simp add: box_def)

text ‹Theorem 47.6›

lemma box_left_mult:
  "|x * y]z = |x]|y]z"
  using box_x_a box_def mult_assoc by force

lemma box_right_mult:
  "|x](y * z) = a(x * a(y * z))"
  by (simp add: box_def)

text ‹Theorem 47.7›

lemma box_right_submult_d_d:
  "|x](d(y) * d(z)) ≤ |x]d(y) * |x]d(z)"
  by (smt a_antitone a_dist_sup a_export_d box_diamond d_a_closed diamond_def mult_left_sub_dist_sup)

lemma box_right_submult_a_d:
  "|x](a(y) * d(z)) ≤ |x]a(y) * |x]d(z)"
  by (metis box_right_submult_d_d a_d_closed)

lemma box_right_submult_d_a:
  "|x](d(y) * a(z)) ≤ |x]d(y) * |x]a(z)"
  using box_right_submult_a_d box_x_a d_def tests_dual.sub_commutative by auto

lemma box_right_submult_a_a:
  "|x](a(y) * a(z)) ≤ |x]a(y) * |x]a(z)"
  by (metis box_right_submult_d_d a_d_closed)

text ‹Theorem 47.8›

lemma box_d_export:
  "|d(x) * y]z = a(x) ⊔ |y]z"
  by (simp add: a_export_d box_def mult_assoc)

lemma box_a_export:
  "|a(x) * y]z = d(x) ⊔ |y]z"
  using box_a_y box_d_closed box_left_mult by auto

text ‹Theorem 47.4›

lemma box_left_antitone:
  "y ≤ x ⟹ |x]z ≤ |y]z"
  by (metis a_antitone box_def mult_left_isotone)

text ‹Theorem 47.3›

lemma box_right_isotone:
  "y ≤ z ⟹ |x]y ≤ |x]z"
  by (metis a_antitone box_def mult_right_isotone)

lemma box_antitone_isotone:
  "y ≤ w ⟹ x ≤ z ⟹ |w]x ≤ |y]z"
  by (meson box_left_antitone box_right_isotone order_trans)

lemma diamond_1_a:
  "|1>a(y) = a(y)"
  by (simp add: d_def diamond_1_y)

lemma diamond_a_y:
  "|a(x)>y = a(x) * d(y)"
  by (metis a_d_closed diamond_d_y)

lemma diamond_a_bot:
  "|a(x)>bot = bot"
  by (simp add: diamond_a_y d_zero)

lemma diamond_a_1:
  "|a(x)>1 = a(x)"
  by (simp add: d_def diamond_x_1)

lemma diamond_a_d:
  "|a(x)>d(y) = a(x) * d(y)"
  by (simp add: diamond_a_y diamond_x_und)

lemma diamond_d_a:
  "|d(x)>a(y) = d(x) * a(y)"
  by (simp add: a_d_closed diamond_d_y)

lemma diamond_a_a:
  "|a(x)>a(y) = a(x) * a(y)"
  by (simp add: a_mult_closed diamond_def)

lemma diamond_a_a_same:
  "|a(x)>a(x) = a(x)"
  by (simp add: diamond_a_a)

lemma diamond_a_export:
  "|a(x) * y>z = a(x) * |y>z"
  using diamond_a_y diamond_associative diamond_def by auto

lemma a_box_a_a:
  "a(p) * |a(p)]a(q) = a(p) * a(q)"
  using box_a_a box_a_bot box_x_bot tests_dual.sup_complement_intro by auto

lemma box_left_lower_bound:
  "|x ⊔ y]z ≤ |x]z"
  by (simp add: box_left_antitone)

lemma box_right_upper_bound:
  "|x]y ≤ |x](y ⊔ z)"
  by (simp add: box_right_isotone)

lemma box_lower_bound_right:
  "|x](d(y) * d(z)) ≤ |x]d(y)"
  by (simp add: box_right_isotone d_mult_left_lower_bound)

lemma box_lower_bound_left:
  "|x](d(y) * d(z)) ≤ |x]d(z)"
  by (simp add: box_right_isotone d_restrict_iff_1)

text ‹Theorem 47.9›

lemma box_d_import:
  "d(x) * |y]z = d(x) * |d(x) * y]z"
  using a_box_a_a box_left_mult box_def d_def by force

text ‹Theorem 47.10›

lemma box_d_promote:
  "|x * d(y)]z = |x * d(y)](d(y) * z)"
  using a_box_a_a box_x_a box_def d_def mult_assoc by auto

text ‹Theorem 47.11›

lemma box_d_import_iff:
  "d(x) ≤ |y]z ⟷ d(x) ≤ |d(x) * y]z"
  using box_d_export box_def d_def tests_dual.shunting by auto

text ‹Theorem 47.12›

lemma box_d_import_iff_2:
  "d(x) * d(y) ≤ |z]w ⟷ d(x) * d(y) ≤ |d(y) * z]w"
  apply (rule iffI)
  using box_d_export le_supI2 apply simp
  by (metis box_d_import d_commutative d_restrict_iff_1)

text ‹Theorem 47.20›

lemma box_demodalisation_2:
  "-p ≤ |y](-q) ⟷ -p * y * --q ≤ Z"
  by (simp add: a_greatest_left_absorber box_def mult_assoc)

lemma box_right_sub_dist_sup:
  "|x]d(y) ⊔ |x]d(z) ≤ |x](d(y) ⊔ d(z))"
  by (simp add: box_right_isotone)

lemma box_diff_var:
  "|x](d(y) ⊔ a(z)) * |x]d(z) ≤ |x]d(z)"
  by (simp add: box_right_dist_sup box_x_d tests_dual.upper_bound_right)

text ‹Theorem 47.19›

lemma diamond_demodalisation_2:
  "|x>y ≤ d(z) ⟷ a(z) * x * d(y) ≤ Z"
  using a_antitone a_greatest_left_absorber a_mult_d d_def diamond_def mult_assoc by fastforce

text ‹Theorem 47.17›

lemma box_below_Z:
  "( |x]y) * x * a(y) ≤ Z"
  by (simp add: a_restrict box_def mult_assoc)

text ‹Theorem 47.18›

lemma box_partial_correctness:
  "|x]1 = 1 ⟷ x * bot ≤ Z"
  by (simp add: box_x_1 a_strict)

lemma diamond_split:
  "|x>y = d(z) * |x>y ⊔ a(z) * |x>y"
  by (metis d_def diamond_def sup_monoid.add_commute tests_dual.sba_dual.sup_cases tests_dual.sub_commutative)

lemma box_import_shunting:
  "-p * -q ≤ |x](-r) ⟷ -q ≤ |-p * x](-r)"
  by (smt box_demodalisation_2 mult_assoc sub_comm sub_mult_closed)

(*
lemma box_dist_mult: "|x](d(y) * d(z)) = |x](d(y)) * |x](d(z))" nitpick [expect=genuine,card=6] oops
lemma box_demodalisation_3: "d(x) ≤ |y]d(z) ⟶ d(x) * y ≤ y * d(z) ⊔ Z" nitpick [expect=genuine,card=6] oops
lemma fbox_diff: "|x](d(y) ⊔ a(z)) ≤ |x]y ⊔ a( |x]z)" nitpick [expect=genuine,card=6] oops
lemma diamond_diff: "|x>y * a( |x>z) ≤ |x>(d(y) * a(z))" nitpick [expect=genuine,card=6] oops
lemma diamond_diff_var: "|x>d(y) ≤ |x>(d(y) * a(z)) ⊔ |x>d(z)" nitpick [expect=genuine,card=6] oops
*)

end

class relative_left_zero_diamond_semiring = relative_diamond_semiring + relative_domain_semiring + idempotent_left_zero_semiring
begin

lemma diamond_right_dist_sup:
  "|x>(y ⊔ z) = |x>y ⊔ |x>z"
  by (simp add: d_dist_sup diamond_def mult_left_dist_sup)

end

class relative_left_zero_box_semiring = relative_box_semiring + relative_left_zero_antidomain_semiring
begin

subclass relative_left_zero_diamond_semiring ..

lemma box_right_mult_d_d:
  "|x](d(y) * d(z)) = |x]d(y) * |x]d(z)"
  using a_dist_sup box_d_a box_def d_def mult_left_dist_sup by auto

lemma box_right_mult_a_d:
  "|x](a(y) * d(z)) = |x]a(y) * |x]d(z)"
  by (metis box_right_mult_d_d a_d_closed)

lemma box_right_mult_d_a:
  "|x](d(y) * a(z)) = |x]d(y) * |x]a(z)"
  using box_right_mult_a_d box_def box_x_a d_def by auto

lemma box_right_mult_a_a:
  "|x](a(y) * a(z)) = |x]a(y) * |x]a(z)"
  using a_dist_sup box_def mult_left_dist_sup tests_dual.sub_sup_demorgan by force

lemma box_demodalisation_3:
  assumes "d(x) ≤ |y]d(z)"
    shows "d(x) * y ≤ y * d(z) ⊔ Z"
proof -
  have "d(x) * y * a(z) ≤ Z"
    using assms a_greatest_left_absorber box_x_d d_def mult_assoc by auto
  thus ?thesis
    by (simp add: a_a_below case_split_right_sup d_def sup_commute mult_assoc)
qed

lemma fbox_diff:
  "|x](d(y) ⊔ a(z)) ≤ |x]y ⊔ a( |x]z)"
  by (smt (z3) a_compl_intro a_dist_sup a_mult_d a_plus_left_lower_bound sup_commute box_def d_def mult_left_dist_sup tests_dual.sba_dual.shunting)

lemma diamond_diff_var:
  "|x>d(y) ≤ |x>(d(y) * a(z)) ⊔ |x>d(z)"
  by (metis d_cancellation_1 diamond_right_dist_sup diamond_right_isotone sup_commute)

lemma diamond_diff:
  "|x>y * a( |x>z) ≤ |x>(d(y) * a(z))"
  by (metis d_a_shunting d_involutive diamond_def diamond_diff_var diamond_x_und)

end

end

Theory Complete_Tests

(* Title:      Complete Tests
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Complete Tests›

theory Complete_Tests

imports Tests

begin

class complete_tests = tests + Sup + Inf +
  assumes sup_test: "test_set A ⟶ Sup A = --Sup A"
  assumes sup_upper: "test_set A ∧ x ∈ A ⟶ x ≤ Sup A"
  assumes sup_least: "test_set A ∧ (∀x∈A . x ≤ -y) ⟶ Sup A ≤ -y"
begin

lemma Sup_isotone:
  "test_set B ⟹ A ⊆ B ⟹ Sup A ≤ Sup B"
  by (metis sup_least sup_test sup_upper test_set_closed subset_eq)

lemma mult_right_dist_sup:
  assumes "test_set A"
    shows "Sup A * -p = Sup { x * -p | x . x ∈ A }"
proof -
  have 1: "test_set { x * -p | x . x ∈ A }"
    by (simp add: assms mult_right_dist_test_set)
  have 2: "Sup { x * -p | x . x ∈ A } ≤ Sup A * -p"
    by (smt (verit, del_insts) assms mem_Collect_eq tests_dual.sub_sup_left_isotone sub_mult_closed sup_test sup_least sup_upper test_set_def)
  have "∀x∈A . x ≤ --(--Sup { x * -p | x . x ∈ A } ⊔ --p)"
  proof
    fix x
    assume 3: "x ∈ A"
    hence "x * -p ⊔ --p ≤ Sup { x * -p | x . x ∈ A } ⊔ --p"
      using 1 by (smt (verit, del_insts) assms mem_Collect_eq tests_dual.sub_inf_left_isotone sub_mult_closed sup_upper test_set_def sup_test)
    thus "x ≤ --(--Sup { x * -p | x . x ∈ A } ⊔ --p)"
      using 1 3 by (smt (z3) assms tests_dual.inf_closed sub_comm test_set_def sup_test sub_mult_closed tests_dual.sba_dual.shunting_right tests_dual.sba_dual.sub_sup_left_isotone tests_dual.inf_absorb tests_dual.inf_less_eq_cases_3)
  qed
  hence "Sup A ≤ --(--Sup { x * -p | x . x ∈ A } ⊔ --p)"
    by (simp add: assms sup_least)
  hence "Sup A * -p ≤ Sup { x * -p | x . x ∈ A }"
    using 1 by (smt (z3) assms sup_test tests_dual.sba_dual.shunting tests_dual.sub_commutative tests_dual.sub_sup_closed tests_dual.sub_sup_demorgan)
  thus ?thesis
    using 1 2 by (smt (z3) assms sup_test tests_dual.sba_dual.sub_sup_closed tests_dual.antisymmetric tests_dual.inf_demorgan tests_dual.inf_idempotent)
qed

lemma mult_left_dist_sup:
  assumes "test_set A"
  shows "-p * Sup A = Sup { -p * x | x . x ∈ A }"
proof -
  have 1: "Sup A * -p = Sup { x * -p | x . x ∈ A }"
    by (simp add: assms mult_right_dist_sup)
  have 2: "-p * Sup A = Sup A * -p"
    by (metis assms sub_comm sup_test)
  have "{ -p * x | x . x ∈ A } = { x * -p | x . x ∈ A }"
    by (metis assms test_set_def tests_dual.sub_commutative)
  thus ?thesis
    using 1 2 by simp
qed

definition Sum :: "(nat ⇒ 'a) ⇒ 'a"
  where "Sum f ≡ Sup { f n | n::nat . True }"

lemma Sum_test:
  "test_seq t ⟹ Sum t = --Sum t"
  using Sum_def sup_test test_seq_test_set by auto

lemma Sum_upper:
  "test_seq t ⟹ t x ≤ Sum t"
  using Sum_def sup_upper test_seq_test_set by auto

lemma Sum_least:
  "test_seq t ⟹ (∀n . t n ≤ -p) ⟹ Sum t ≤ -p"
  using Sum_def sup_least test_seq_test_set by force

lemma mult_right_dist_Sum:
  "test_seq t ⟹ (∀n . t n * -p ≤ -q) ⟹ Sum t * -p ≤ -q"
  by (smt (verit, del_insts) CollectD Sum_def sup_least sup_test test_seq_test_set test_set_def tests_dual.sba_dual.shunting_right tests_dual.sba_dual.sub_sup_closed)

lemma mult_left_dist_Sum:
  "test_seq t ⟹ (∀n . -p * t n ≤ -q) ⟹ -p * Sum t ≤ -q"
  by (smt (verit, del_insts) Sum_def mem_Collect_eq mult_left_dist_sup sub_mult_closed sup_least test_seq_test_set test_set_def)

lemma pSum_below_Sum:
  "test_seq t ⟹ pSum t m ≤ Sum t"
  using Sum_test Sum_upper nat_test_def pSum_below_sum test_seq_def mult_right_dist_Sum by auto

lemma pSum_sup:
  assumes "test_seq t"
    shows "pSum t m = Sup { t i | i . i ∈ {..<m} }"
proof -
  have 1: "test_set { t i | i . i ∈ {..<m} }"
    using assms test_seq_test_set test_set_def by auto
  have "∀y∈{ t i | i . i ∈ {..<m} } . y ≤ --pSum t m"
    using assms pSum_test pSum_upper by force
  hence 2: "Sup { t i | i . i ∈ {..<m} } ≤ --pSum t m"
    using 1 by (simp add: sup_least)
  have "pSum t m ≤ Sup { t i | i . i ∈ {..<m} }"
  proof (induct m)
    case 0
    show ?case
      by (smt (verit, ccfv_SIG) Collect_empty_eq empty_iff lessThan_0 pSum.simps(1) sup_test test_set_def tests_dual.top_greatest)
  next
    case (Suc n)
    have 4: "test_set {t i |i. i ∈ {..<n}}"
      using assms test_seq_def test_set_def by auto
    have 5: "test_set {t i |i. i < Suc n}"
      using assms test_seq_def test_set_def by force
    hence 6: "Sup {t i |i. i < Suc n} = --Sup {t i |i. i < Suc n}"
      using sup_test by auto
    hence "∀x∈{t i |i. i ∈ {..<n}} . x ≤ --Sup {t i |i. i < Suc n}"
      using 5 less_Suc_eq sup_upper by fastforce
    hence 7: "Sup {t i |i. i ∈ {..<n}} ≤ --Sup {t i |i. i < Suc n}"
      using 4 by (simp add: sup_least)
    have "t n ∈ {t i |i. i < Suc n}"
      by auto
    hence "t n ≤ Sup {t i |i. i < Suc n}"
      using 5 by (simp add: sup_upper)
    hence "pSum t n ⊔ t n ≤ Sup {t i |i. i <Suc n}"
      using Suc 4 6 7 by (smt assms tests_dual.greatest_lower_bound test_seq_def pSum_test tests_dual.sba_dual.transitive sup_test)
    thus ?case
      by simp
  qed
  thus ?thesis
    using 1 2 by (smt assms tests_dual.antisymmetric sup_test pSum_test)
qed

definition Prod :: "(nat ⇒ 'a) ⇒ 'a"
  where "Prod f ≡ Inf { f n | n::nat . True }"

lemma Sum_range:
  "Sum f = Sup (range f)"
  by (simp add: Sum_def image_def)

lemma Prod_range:
  "Prod f = Inf (range f)"
  by (simp add: Prod_def image_def)

end

end

Theory Complete_Domain

(* Title:      Complete Domain
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Complete Domain›

theory Complete_Domain

imports Relative_Domain Complete_Tests

begin

class complete_antidomain_semiring = relative_antidomain_semiring + complete_tests +
  assumes a_dist_Sum: "ascending_chain f ⟶ -(Sum f) = Prod (λn . -f n)"
  assumes a_dist_Prod: "descending_chain f ⟶ -(Prod f) = Sum (λn . -f n)"
begin

lemma a_ascending_chain:
  "ascending_chain f ⟹ descending_chain (λn . -f n)"
  by (simp add: a_antitone ascending_chain_def descending_chain_def)

lemma a_descending_chain:
  "descending_chain f ⟹ ascending_chain (λn . -f n)"
  by (simp add: a_antitone ord.ascending_chain_def ord.descending_chain_def)

lemma d_dist_Sum:
  "ascending_chain f ⟹ d(Sum f) = Sum (λn . d(f n))"
  by (simp add: d_def a_ascending_chain a_dist_Prod a_dist_Sum)

lemma d_dist_Prod:
  "descending_chain f ⟹ d(Prod f) = Prod (λn . d(f n))"
  by (simp add: d_def a_dist_Sum a_dist_Prod a_descending_chain)

end

end

Theory Preconditions

(* Title:      Preconditions
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Preconditions›

theory Preconditions

imports Tests

begin

class pre =
  fixes pre :: "'a ⇒ 'a ⇒ 'a" (infixr "«" 55)

class precondition = tests + pre +
  assumes pre_closed: "x«-q = --(x«-q)"
  assumes pre_seq: "x*y«-q = x«y«-q"
  assumes pre_lower_bound_right: "x«-p*-q ≤ x«-q"
  assumes pre_one_increasing: "-q ≤ 1«-q"
begin

text ‹Theorem 39.2›

lemma pre_sub_distr:
  "x«-p*-q ≤ (x«-p)*(x«-q)"
  by (smt (z3) pre_closed pre_lower_bound_right tests_dual.sub_commutative tests_dual.sub_sup_closed tests_dual.least_upper_bound)

text ‹Theorem 39.5›

lemma pre_below_one:
  "x«-p ≤ 1"
  by (metis pre_closed tests_dual.sub_bot_least)

lemma pre_lower_bound_left:
  "x«-p*-q ≤ x«-p"
  using pre_lower_bound_right tests_dual.sub_commutative by fastforce

text ‹Theorem 39.1›

lemma pre_iso:
  "-p ≤ -q ⟹ x«-p ≤ x«-q"
  by (metis leq_def pre_lower_bound_right)

text ‹Theorem 39.4 and Theorem 40.9›

lemma pre_below_pre_one:
  "x«-p ≤ x«1"
  using tests_dual.sba_dual.one_def pre_iso tests_dual.sub_bot_least by blast

text ‹Theorem 39.3›

lemma pre_seq_below_pre_one:
  "x*y«1 ≤ x«1"
  by (metis one_def pre_below_pre_one pre_closed pre_seq)

text ‹Theorem 39.6›

lemma pre_compose:
  "-p ≤ x«-q ⟹ -q ≤ y«-r ⟹ -p ≤ x*y«-r"
  by (metis pre_closed pre_iso tests_dual.transitive pre_seq)

(*
lemma pre_test_test: "-p*(-p«-q) = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test_promote: "-p«-q = -p«-p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = --p⊔-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=4] oops
lemma pre_distr_plus: "x«-p⊔-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=2] oops
*)

end

class precondition_test_test = precondition +
  assumes pre_test_test: "-p*(-p«-q) = -p*-q"
begin

lemma pre_one:
  "1«-p = -p"
  by (metis pre_closed pre_test_test tests_dual.sba_dual.one_def tests_dual.sup_left_unit)

lemma pre_import:
  "-p*(x«-q) = -p*(-p*x«-q)"
  by (metis pre_closed pre_seq pre_test_test)

lemma pre_import_composition:
  "-p*(-p*x*y«-q) = -p*(x«y«-q)"
  by (metis pre_closed pre_seq pre_import)

lemma pre_import_equiv:
  "-p ≤ x«-q ⟷ -p ≤ -p*x«-q"
  by (metis leq_def pre_closed pre_import)

lemma pre_import_equiv_mult:
  "-p*-q ≤ x«-s ⟷ -p*-q ≤ -q*x«-s"
  by (smt leq_def pre_closed sub_assoc sub_mult_closed pre_import)

(*
lemma pre_test_promote: "-p«-q = -p«-p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = --p⊔-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=4] oops
lemma pre_distr_plus: "x«-p⊔-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=2] oops
*)

end

class precondition_promote = precondition +
  assumes pre_test_promote: "-p«-q = -p«-p*-q"
begin

lemma pre_mult_test_promote:
  "x*-p«-q = x*-p«-p*-q"
  by (metis pre_seq pre_test_promote sub_mult_closed)

(*
lemma pre_test_test: "-p*(-p«-q) = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = --p⊔-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=4] oops
lemma pre_distr_plus: "x«-p⊔-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=2] oops
*)

end

class precondition_test_box = precondition +
  assumes pre_test: "-p«-q = --p⊔-q"
begin

lemma pre_test_neg:
  "--p*(-p«-q) = --p"
  by (simp add: pre_test)

lemma pre_bot:
  "bot«-q = 1"
  by (metis pre_test tests_dual.sba_dual.one_def tests_dual.sba_dual.sup_left_zero tests_dual.top_double_complement)

lemma pre_export:
  "-p*x«-q = --p⊔(x«-q)"
  by (metis pre_closed pre_seq pre_test)

lemma pre_neg_mult:
  "--p ≤ -p*x«-q"
  by (metis leq_def pre_closed pre_seq pre_test_neg)

lemma pre_test_test_same:
  "-p«-p = 1"
  using pre_test tests_dual.sba_dual.less_eq_sup_top tests_dual.sba_dual.reflexive by auto

lemma test_below_pre_test_mult:
  "-q ≤ -p«-p*-q"
  by (metis pre_test tests_dual.sba_dual.reflexive tests_dual.sba_dual.shunting tests_dual.sub_sup_closed)

lemma test_below_pre_test:
  "-q ≤ -p«-q"
  by (simp add: pre_test tests_dual.sba_dual.upper_bound_right)

lemma test_below_pre_test_2:
  "--p ≤ -p«-q"
  by (simp add: pre_test tests_dual.sba_dual.upper_bound_left)

lemma pre_test_bot:
  "-p«bot = --p"
  by (metis pre_test tests_dual.sba_dual.sup_right_unit tests_dual.top_double_complement)

lemma pre_test_one:
  "-p«1 = 1"
  by (metis pre_seq pre_bot tests_dual.sup_right_zero)

subclass precondition_test_test
  apply unfold_locales
  by (simp add: pre_test tests_dual.sup_complement_intro)

subclass precondition_promote
  apply unfold_locales
  by (metis pre_test tests_dual.sba_dual.sub_commutative tests_dual.sub_sup_closed tests_dual.inf_complement_intro)

(*
lemma pre_test: "-p«-q = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)" oops
lemma pre_distr_plus: "x«-p⊔-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=2] oops
*)

end

class precondition_test_diamond = precondition +
  assumes pre_test: "-p«-q = -p*-q"
begin

lemma pre_test_neg:
  "--p*(-p«-q) = bot"
  by (simp add: pre_test tests_dual.sub_associative tests_dual.sub_commutative)

lemma pre_bot:
  "bot«-q = bot"
  by (metis pre_test tests_dual.sup_left_zero tests_dual.top_double_complement)

lemma pre_export:
  "-p*x«-q = -p*(x«-q)"
  by (metis pre_closed pre_seq pre_test)

lemma pre_neg_mult:
  "-p*x«-q ≤ -p"
  by (metis pre_closed pre_export tests_dual.upper_bound_left)

lemma pre_test_test_same:
  "-p«-p = -p"
  by (simp add: pre_test)

lemma test_above_pre_test_plus:
  "--p«-p⊔-q ≤ -q"
  using pre_test tests_dual.sba_dual.inf_complement_intro tests_dual.sub_commutative tests_dual.sub_inf_def tests_dual.upper_bound_left by auto

lemma test_above_pre_test:
  "-p«-q ≤ -q"
  by (simp add: pre_test tests_dual.upper_bound_right)

lemma test_above_pre_test_2:
  "-p«-q ≤ -p"
  by (simp add: pre_test tests_dual.upper_bound_left)

lemma pre_test_bot:
  "-p«bot = bot"
  by (metis pre_test tests_dual.sup_right_zero tests_dual.top_double_complement)

lemma pre_test_one:
  "-p«1 = -p"
  by (metis pre_test tests_dual.complement_top tests_dual.sup_right_unit)

subclass precondition_test_test
  apply unfold_locales
  by (simp add: pre_test tests_dual.sub_associative)

subclass precondition_promote
  apply unfold_locales
  by (metis pre_seq pre_test tests_dual.sup_idempotent)

(*
lemma pre_test: "-p«-q = --p⊔-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=6] oops
lemma pre_distr_plus: "x«-p⊔-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=2] oops
*)

end

class precondition_distr_mult = precondition +
  assumes pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)"
begin

(*
lemma pre_test_test: "-p*(-p«-q) = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test_promote: "-p«-q = -p«-p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = --p⊔-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_plus: "x«-p⊔-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=2] oops
*)

end

class precondition_distr_plus = precondition +
  assumes pre_distr_plus: "x«-p⊔-q = (x«-p)⊔(x«-q)"
begin

(*
lemma pre_test_test: "-p*(-p«-q) = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test_promote: "-p«-q = -p«-p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = --p⊔-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=4] oops
*)

end

end

Theory Hoare

(* Title:      Hoare Calculus
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Hoare Calculus›

theory Hoare

imports Complete_Tests Preconditions

begin

class ite =
  fixes ite :: "'a ⇒ 'a ⇒ 'a ⇒ 'a" ("_ ⊲ _ ⊳ _" [58,58,58] 57)

class hoare_triple =
  fixes hoare_triple :: "'a ⇒ 'a ⇒ 'a ⇒ bool" ("_ ⦃ _ ⦄ _" [54,54,54] 53)

class ifthenelse = precondition + ite +
  assumes ite_pre: "x⊲-p⊳y«-q = -p*(x«-q) ⊔ --p*(y«-q)"
begin

text ‹Theorem 40.2›

lemma ite_pre_then:
  "-p*(x⊲-p⊳y«-q) = -p*(x«-q)"
proof -
  have "-p*(x⊲-p⊳y«-q) = -p*(x«-q) ⊔ bot*(y«-q)"
    by (smt (z3) ite_pre pre_closed tests_dual.sba_dual.sup_right_unit tests_dual.sub_commutative tests_dual.sup_left_zero tests_dual.sup_right_dist_inf tests_dual.top_double_complement tests_dual.wnf_lemma_1)
  thus ?thesis
    by (metis pre_closed tests_dual.sba_dual.sup_right_unit tests_dual.sub_sup_closed tests_dual.sup_left_zero)
qed

text ‹Theorem 40.3›

lemma ite_pre_else:
  "--p*(x⊲-p⊳y«-q) = --p*(y«-q)"
proof -
  have "--p*(x⊲-p⊳y«-q) = bot*(x«-q) ⊔ --p*(y«-q)"
    by (smt (z3) ite_pre pre_closed tests_dual.sub_commutative tests_dual.sub_inf_left_zero tests_dual.sup_left_zero tests_dual.sup_right_dist_inf tests_dual.top_double_complement tests_dual.wnf_lemma_3)
  thus ?thesis
    by (metis pre_closed tests_dual.sba_dual.sub_sup_demorgan tests_dual.sub_inf_left_zero tests_dual.sup_left_zero)
qed

lemma ite_import_mult_then:
  "-p*-q ≤ x«-r ⟹ -p*-q ≤ x⊲-p⊳y«-r"
  by (smt ite_pre_then leq_def pre_closed sub_assoc sub_comm sub_mult_closed)

lemma ite_import_mult_else:
  "--p*-q ≤ y«-r ⟹ --p*-q ≤ x⊲-p⊳y«-r"
  by (smt ite_pre_else leq_def pre_closed sub_assoc sub_comm sub_mult_closed)

text ‹Theorem 40.1›

lemma ite_import_mult:
  "-p*-q ≤ x«-r ⟹ --p*-q ≤ y«-r ⟹ -q ≤ x⊲-p⊳y«-r"
  by (smt (verit) ite_import_mult_else ite_import_mult_then pre_closed tests_dual.sba_dual.inf_less_eq_cases)

end

class whiledo = ifthenelse + while +
  assumes while_pre: "-p⋆x«-q = -p*(x«-p⋆x«-q) ⊔ --p*-q"
  assumes while_post: "-p⋆x«-q = -p⋆x«--p*-q"
begin

text ‹Theorem 40.4›

lemma while_pre_then:
  "-p*(-p⋆x«-q) = -p*(x«-p⋆x«-q)"
  by (smt pre_closed tests_dual.sub_commutative while_pre tests_dual.wnf_lemma_1)

text ‹Theorem 40.5›

lemma while_pre_else:
  "--p*(-p⋆x«-q) = --p*-q"
  by (smt pre_closed tests_dual.sub_commutative while_pre tests_dual.wnf_lemma_3)

text ‹Theorem 40.6›

lemma while_pre_sub_1:
  "-p⋆x«-q ≤ x*(-p⋆x)⊲-p⊳1«-q"
  by (smt (z3) ite_import_mult pre_closed pre_one_increasing pre_seq tests_dual.sba_dual.transitive tests_dual.sub_sup_closed tests_dual.upper_bound_right while_pre_else while_pre_then)

text ‹Theorem 40.7›

lemma while_pre_sub_2:
  "-p⋆x«-q ≤ x⊲-p⊳1«-p⋆x«-q"
  by (smt (z3) ite_import_mult pre_closed pre_one_increasing tests_dual.sba_dual.transitive tests_dual.sub_sup_closed tests_dual.upper_bound_right while_pre_then)

text ‹Theorem 40.8›

lemma while_pre_compl:
  "--p ≤ -p⋆x«--p"
  by (metis pre_closed tests_dual.sup_idempotent tests_dual.upper_bound_right while_pre_else)

lemma while_pre_compl_one:
  "--p ≤ -p⋆x«1"
  by (metis tests_dual.sba_dual.top_double_complement while_post tests_dual.sup_right_unit while_pre_compl)

text ‹Theorem 40.10›

lemma while_export_equiv:
  "-q ≤ -p⋆x«1 ⟷ -p*-q ≤ -p⋆x«1"
  by (smt pre_closed tests_dual.sba_dual.shunting tests_dual.sba_dual.sub_less_eq_def tests_dual.sba_dual.top_double_complement while_pre_compl_one)

lemma nat_test_pre:
  assumes "nat_test t s"
      and "-q ≤ s"
      and "∀n . t n*-p*-q ≤ x«pSum t n*-q"
    shows "-q ≤ -p⋆x«--p*-q"
proof -
  have 1: "-q*--p ≤ -p⋆x«--p*-q"
    by (metis pre_closed tests_dual.sub_commutative while_post tests_dual.upper_bound_right while_pre_else)
  have "∀n . t n*-p*-q ≤ -p⋆x«--p*-q"
  proof
    fix n
    show "t n*-p*-q ≤ -p⋆x«--p*-q"
    proof (induct n rule: nat_less_induct)
      fix n
      have 2: "t n = --(t n)"
        using assms(1) nat_test_def by auto
      assume "∀m<n . t m*-p*-q ≤ -p⋆x«--p*-q"
      hence "∀m<n . t m*-p*-q ⊔ t m*--p*-q ≤ -p⋆x«--p*-q"
        using 1 by (smt (verit, del_insts) assms(1) tests_dual.greatest_lower_bound leq_def nat_test_def pre_closed tests_dual.sub_associative tests_dual.sub_commutative sub_mult_closed)
      hence "∀m<n . t m*-q ≤ -p⋆x«--p*-q"
        by (smt (verit, del_insts) assms(1) tests_dual.sup_right_unit tests_dual.sup_left_dist_inf tests_dual.sup_right_dist_inf nat_test_def tests_dual.inf_complement sub_mult_closed)
      hence "pSum t n*-q ≤ -p⋆x«--p*-q"
        by (smt assms(1) pSum_below_nat pre_closed sub_mult_closed)
      hence "t n*-p*-q*(-p⋆x«--p*-q) = t n*-p*-q"
        using 2 by (smt assms(1,3) leq_def pSum_test_nat pre_closed pre_sub_distr sub_assoc sub_comm sub_mult_closed transitive while_pre_then)
      thus "t n*-p*-q ≤ -p⋆x«--p*-q"
        using 2 by (smt (z3) pre_closed tests_dual.sub_sup_closed tests_dual.upper_bound_right)
    qed
  qed
  hence "-q*-p ≤ -p⋆x«--p*-q"
    by (smt (verit, del_insts) assms(1,2) leq_def nat_test_def pre_closed tests_dual.sub_associative tests_dual.sub_commutative sub_mult_closed)
  thus ?thesis
    using 1 by (smt (z3) pre_closed tests_dual.sba_dual.inf_less_eq_cases tests_dual.sub_commutative tests_dual.sub_sup_closed)
qed

lemma nat_test_pre_1:
  assumes "nat_test t s"
      and "-r ≤ s"
      and "-r ≤ -q"
      and "∀n . t n*-p*-q ≤ x«pSum t n*-q"
    shows "-r ≤ -p⋆x«--p*-q"
proof -
  let ?qs = "-q*s"
  have 1: "-r ≤ ?qs"
    by (metis assms(1-3) nat_test_def tests_dual.least_upper_bound)
  have "∀n . t n*-p*?qs ≤ x«pSum t n*?qs"
  proof
    fix n
    have 2: "pSum t n ≤ s"
      by (simp add: assms(1) pSum_below_sum)
    have "t n = t n * s"
      by (metis assms(1) nat_test_def tests_dual.sba_dual.less_eq_inf)
    hence "t n*-p*?qs = t n*-p*-q"
      by (smt (verit, ccfv_threshold) assms(1) nat_test_def tests_dual.sub_sup_closed tests_dual.sub_associative tests_dual.sub_commutative)
    also have "t n*-p*-q ≤ x«pSum t n*-q"
      by (simp add: assms(4))
    also have "x«pSum t n*-q = x«pSum t n*?qs"
      using 2 by (smt (verit, ccfv_SIG) assms(1) leq_def nat_test_def pSum_test_nat tests_dual.sub_associative tests_dual.sub_commutative)
    finally show "t n*-p*?qs ≤ x«pSum t n*?qs"
      .
  qed
  hence 3: "?qs ≤ -p⋆x«--p*?qs"
    by (smt (verit, ccfv_threshold) assms(1) tests_dual.upper_bound_left tests_dual.upper_bound_right nat_test_def nat_test_pre pSum_test_nat pre_closed tests_dual.sub_associative sub_mult_closed transitive)
  have "-p⋆x«--p*?qs ≤ -p⋆x«--p*-q"
    by (metis assms(1) nat_test_def pre_lower_bound_left tests_dual.sub_sup_closed while_post)
  thus ?thesis
    using 1 3 by (smt (verit, del_insts) leq_def tests_dual.sub_associative assms(1) nat_test_def pre_closed sub_mult_closed)
qed

lemma nat_test_pre_2:
  assumes "nat_test t s"
      and "-r ≤ s"
      and "∀n . t n*-p ≤ x«pSum t n"
    shows "-r ≤ -p⋆x«1"
proof -
  have 1: "-r ≤ -p⋆x«--p*s"
    by (smt (verit, ccfv_threshold) assms leq_def nat_test_def nat_test_pre_1 pSum_below_sum pSum_test_nat tests_dual.sub_associative tests_dual.sub_commutative)
  have "-p⋆x«--p*s ≤ -p⋆x«1"
    by (metis assms(1) nat_test_def pre_below_pre_one while_post)
  thus ?thesis
    using 1 by (smt (verit) assms(1) nat_test_def pre_closed tests_dual.sba_dual.top_double_complement while_post tests_dual.transitive)
qed

lemma nat_test_pre_3:
  assumes "nat_test t s"
      and "-q ≤ s"
      and "∀n . t n*-p*-q ≤ x«pSum t n*-q"
    shows "-q ≤ -p⋆x«1"
proof -
  have "-p⋆x«--p*-q ≤ -p⋆x«1"
    by (metis pre_below_pre_one sub_mult_closed)
  thus ?thesis
    by (smt (verit, ccfv_threshold) assms pre_closed tests_dual.sba_dual.top_double_complement tests_dual.sba_dual.transitive tests_dual.sub_sup_closed nat_test_pre)
qed

definition aL :: "'a"
  where "aL ≡ 1⋆1«1"

lemma aL_test:
  "aL = --aL"
  by (metis aL_def one_def pre_closed)

end

class atoms = tests +
  fixes Atomic_program :: "'a set"
  fixes Atomic_test :: "'a set"
  assumes one_atomic_program: "1 ∈ Atomic_program"
  assumes zero_atomic_test: "bot ∈ Atomic_test"
  assumes atomic_test_test: "p ∈ Atomic_test ⟶ p = --p"

class while_program = whiledo + atoms + power
begin

inductive_set Test_expression :: "'a set"
  where atom_test: "p ∈ Atomic_test ⟹ p ∈ Test_expression"
      | neg_test:  "p ∈ Test_expression ⟹ -p ∈ Test_expression"
      | conj_test: "p ∈ Test_expression ⟹ q ∈ Test_expression ⟹ p*q ∈ Test_expression"

lemma test_expression_test:
  "p ∈ Test_expression ⟹ p = --p"
  apply (induct rule: Test_expression.induct)
  apply (simp add: atomic_test_test)
  apply simp
  by (metis tests_dual.sub_sup_closed)

lemma disj_test:
  "p ∈ Test_expression ⟹ q ∈ Test_expression ⟹ p⊔q ∈ Test_expression"
  by (smt conj_test neg_test tests_dual.sub_inf_def test_expression_test)

lemma zero_test_expression:
  "bot ∈ Test_expression"
  by (simp add: Test_expression.atom_test zero_atomic_test)

lemma one_test_expression:
  "1 ∈ Test_expression"
  using Test_expression.simps tests_dual.sba_dual.one_def zero_test_expression by blast

lemma pSum_test_expression:
  "(∀n . t n ∈ Test_expression) ⟹ pSum t m ∈ Test_expression"
  apply (induct m)
  apply (simp add: zero_test_expression)
  by (simp add: disj_test)

inductive_set While_program :: "'a set"
  where atom_prog:  "x ∈ Atomic_program ⟹ x ∈ While_program"
      | seq_prog:   "x ∈ While_program ⟹ y ∈ While_program ⟹ x*y ∈ While_program"
      | cond_prog:  "p ∈ Test_expression ⟹ x ∈ While_program ⟹ y ∈ While_program ⟹ x⊲p⊳y ∈ While_program"
      | while_prog: "p ∈ Test_expression ⟹ x ∈ While_program ⟹ p⋆x ∈ While_program"

lemma one_while_program:
  "1 ∈ While_program"
  by (simp add: While_program.atom_prog one_atomic_program)

lemma power_while_program:
  "x ∈ While_program ⟹ x^m ∈ While_program"
  apply (induct m)
  apply (simp add: one_while_program)
  by (simp add: While_program.seq_prog)

inductive_set Pre_expression :: "'a set"
  where test_pre: "p ∈ Test_expression ⟹ p ∈ Pre_expression"
      | neg_pre:  "p ∈ Pre_expression ⟹ -p ∈ Pre_expression"
      | conj_pre: "p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ p*q ∈ Pre_expression"
      | pre_pre:  "p ∈ Pre_expression ⟹ x ∈ While_program ⟹ x«p ∈ Pre_expression"

lemma pre_expression_test:
  "p ∈ Pre_expression ⟹ p = --p"
  apply (induct rule: Pre_expression.induct)
  apply (simp add: test_expression_test)
  apply simp
  apply (metis sub_mult_closed)
  by (metis pre_closed)

lemma disj_pre:
  "p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ p⊔q ∈ Pre_expression"
  by (smt conj_pre neg_pre tests_dual.sub_inf_def pre_expression_test)

lemma zero_pre_expression:
  "bot ∈ Pre_expression"
  by (simp add: Pre_expression.test_pre zero_test_expression)

lemma one_pre_expression:
  "1 ∈ Pre_expression"
  by (simp add: Pre_expression.test_pre one_test_expression)

lemma pSum_pre_expression:
  "(∀n . t n ∈ Pre_expression) ⟹ pSum t m ∈ Pre_expression"
  apply (induct m)
  apply (simp add: zero_pre_expression)
  by (simp add: disj_pre)

lemma aL_pre_expression:
  "aL ∈ Pre_expression"
  by (simp add: Pre_expression.pre_pre While_program.while_prog aL_def one_pre_expression one_test_expression one_while_program)

end

class hoare_calculus = while_program + complete_tests
begin

definition tfun :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a"
  where "tfun p x q r ≡ p ⊔ (x«q*r)"

lemma tfun_test:
  "p = --p ⟹ q = --q ⟹ r = --r ⟹ tfun p x q r = --tfun p x q r"
  by (smt tfun_def sub_mult_closed pre_closed tests_dual.inf_closed)

lemma tfun_pre_expression:
  "x ∈ While_program ⟹ p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ r ∈ Pre_expression ⟹ tfun p x q r ∈ Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.pre_pre disj_pre tfun_def)

lemma tfun_iso:
  "p = --p ⟹ q = --q ⟹ r = --r ⟹ s = --s ⟹ r ≤ s ⟹ tfun p x q r ≤ tfun p x q s"
  by (smt tfun_def tests_dual.sub_sup_right_isotone pre_iso sub_mult_closed tests_dual.sub_inf_right_isotone pre_closed)

definition tseq :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ nat ⇒ 'a"
  where "tseq p x q r m ≡ (tfun p x q ^ m) r"

lemma tseq_test:
  "p = --p ⟹ q = --q ⟹ r = --r ⟹ tseq p x q r m = --tseq p x q r m"
  apply (induct m)
  apply (smt tseq_def tfun_test power_zero_id id_def)
  by (metis tseq_def tfun_test power_succ_unfold_ext)

lemma tseq_test_seq:
  "p = --p ⟹ q = --q ⟹ r = --r ⟹ test_seq (tseq p x q r)"
  using test_seq_def tseq_test by auto

lemma tseq_pre_expression:
  "x ∈ While_program ⟹ p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ r ∈ Pre_expression ⟹ tseq p x q r m ∈ Pre_expression"
  apply (induct m)
  apply (smt tseq_def id_def power_zero_id)
  by (smt tseq_def power_succ_unfold_ext tfun_pre_expression)

definition tsum :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a"
  where "tsum p x q r ≡ Sum (tseq p x q r)"

lemma tsum_test:
  "p = --p ⟹ q = --q ⟹ r = --r ⟹ tsum p x q r = --tsum p x q r"
  using Sum_test tseq_test_seq tsum_def by auto

lemma t_fun_test:
  "q = --q ⟹ tfun (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) = --tfun (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
  by (metis aL_test pre_closed tests_dual.sba_dual.double_negation tfun_def tfun_test)

lemma t_fun_pre_expression:
  "x ∈ While_program ⟹ p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ tfun (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) ∈ Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre tfun_pre_expression)

lemma t_seq_test:
  "q = --q ⟹ tseq (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) m = --tseq (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) m"
  by (metis aL_test pre_closed tests_dual.sba_dual.double_negation tfun_def tfun_test tseq_test)

lemma t_seq_test_seq:
  "q = --q ⟹ test_seq (tseq (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)))"
  using test_seq_def t_seq_test by auto

lemma t_seq_pre_expression:
  "x ∈ While_program ⟹ p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ tseq (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) m ∈ Pre_expression"
  using Pre_expression.pre_pre Pre_expression.test_pre Test_expression.neg_test While_program.while_prog aL_pre_expression tfun_def tfun_pre_expression tseq_pre_expression by auto

lemma t_sum_test:
  "q = --q ⟹ tsum (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) = --tsum (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
  using Sum_test t_seq_test_seq tsum_def by auto

definition tfun2 :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a"
  where "tfun2 p q x r s ≡ p ⊔ q*(x«r*s)"

lemma tfun2_test:
  "p = --p ⟹ q = --q ⟹ r = --r ⟹ s = --s ⟹ tfun2 p q x r s = --tfun2 p q x r s"
  by (smt tfun2_def sub_mult_closed pre_closed tests_dual.inf_closed)

lemma tfun2_pre_expression:
  "x ∈ While_program ⟹ p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ r ∈ Pre_expression ⟹ s ∈ Pre_expression ⟹ tfun2 p q x r s ∈ Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.pre_pre disj_pre tfun2_def)

lemma tfun2_iso:
  "p = --p ⟹ q = --q ⟹ r = --r ⟹ s1 = --s1 ⟹ s2 = --s2 ⟹ s1 ≤ s2 ⟹ tfun2 p q x r s1 ≤ tfun2 p q x r s2"
  by (smt tfun2_def tests_dual.sub_inf_right_isotone pre_iso sub_mult_closed tests_dual.sub_sup_right_isotone pre_closed)

definition tseq2 :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ nat ⇒ 'a"
  where "tseq2 p q x r s m ≡ (tfun2 p q x r ^ m) s"

lemma tseq2_test:
  "p = --p ⟹ q = --q ⟹ r = --r ⟹ s = --s ⟹ tseq2 p q x r s m = --tseq2 p q x r s m"
  apply (induct m)
  apply (smt tseq2_def power_zero_id id_def)
  by (smt tseq2_def tfun2_test power_succ_unfold_ext)

lemma tseq2_test_seq:
  "p = --p ⟹ q = --q ⟹ r = --r ⟹ s = --s ⟹ test_seq (tseq2 p q x r s)"
  using test_seq_def tseq2_test by force

lemma tseq2_pre_expression:
  "x ∈ While_program ⟹ p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ r ∈ Pre_expression ⟹ s ∈ Pre_expression ⟹ tseq2 p q x r s m ∈ Pre_expression"
  apply (induct m)
  apply (smt tseq2_def id_def power_zero_id)
  by (smt tseq2_def power_succ_unfold_ext tfun2_pre_expression)

definition tsum2 :: "'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a ⇒ 'a"
  where "tsum2 p q x r s ≡ Sum (tseq2 p q x r s)"

lemma tsum2_test:
  "p = --p ⟹ q = --q ⟹ r = --r ⟹ s = --s ⟹ tsum2 p q x r s = --tsum2 p q x r s"
  using Sum_test tseq2_test_seq tsum2_def by force

lemma t_fun2_test:
  "p = --p ⟹ q = --q ⟹ tfun2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) = --tfun2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL))"
  by (smt (z3) aL_test pre_closed tests_dual.sub_sup_closed tfun2_def tfun2_test)

lemma t_fun2_pre_expression:
  "x ∈ While_program ⟹ p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ tfun2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) ∈ Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre tfun2_pre_expression)

lemma t_seq2_test:
  "p = --p ⟹ q = --q ⟹ tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m = --tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m"
  by (smt (z3) aL_test pre_closed tests_dual.sub_sup_closed tfun2_def tfun2_test tseq2_test)

lemma t_seq2_test_seq:
  "p = --p ⟹ q = --q ⟹ test_seq (tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)))"
  using test_seq_def t_seq2_test by auto

lemma t_seq2_pre_expression:
  "x ∈ While_program ⟹ p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m ∈ Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre tseq2_pre_expression)

lemma t_sum2_test:
  "p = --p ⟹ q = --q ⟹ tsum2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) = --tsum2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL))"
  using Sum_test t_seq2_test_seq tsum2_def by auto

lemma t_seq2_below_t_seq:
  assumes "p ∈ Test_expression"
      and "q ∈ Pre_expression"
    shows "tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m ≤ tseq (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL)) m"
proof -
  let ?t2 = "tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL))"
  let ?t = "tseq (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
  show "?thesis"
  proof (induct m)
    case 0
    show "?t2 0 ≤ ?t 0"
      by (smt assms aL_test id_def tests_dual.upper_bound_left tests_dual.upper_bound_right tests_dual.inf_isotone power_zero_id pre_closed pre_expression_test sub_mult_closed test_pre tseq2_def tseq_def)
  next
    fix m
    assume "?t2 m ≤ ?t m"
    hence 1: "?t2 (Suc m) ≤ tfun2 (- p * q) p x (p ⋆ x « q) (?t m)"
      by (smt assms power_succ_unfold_ext pre_closed pre_expression_test sub_mult_closed t_seq2_test t_seq_test test_pre tfun2_iso tseq2_def)
    have "... ≤ ?t (Suc m)"
      by (smt assms tests_dual.upper_bound_left tests_dual.upper_bound_right tests_dual.inf_isotone power_succ_unfold_ext pre_closed pre_expression_test sub_mult_closed t_seq_test test_pre tfun2_def tfun_def tseq_def)
    thus "?t2 (Suc m) ≤ ?t (Suc m)"
      using 1 by (smt (verit, del_insts) assms pre_closed pre_expression_test test_expression_test tests_dual.sba_dual.transitive tests_dual.sub_sup_closed t_seq2_test t_seq_test tfun2_test)
  qed
qed

lemma t_seq2_below_t_sum:
  "p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m ≤ tsum (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
   by (smt (verit, del_insts) Sum_upper pre_expression_test t_seq2_below_t_seq t_seq2_test t_seq_test t_sum_test test_pre test_seq_def tsum_def leq_def tests_dual.sub_associative)

lemma t_sum2_below_t_sum:
  "p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ tsum2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) ≤ tsum (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
  by (smt Sum_least pre_expression_test t_seq2_below_t_sum t_seq2_test t_sum_test test_pre test_seq_def tsum2_def)

lemma t_seq2_below_w:
  "p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m ≤ p⋆x«q"
  apply (cases m)
  apply (smt aL_test id_def tests_dual.upper_bound_left tests_dual.sub_sup_right_isotone tests_dual.inf_commutative tests_dual.sub_inf_right_isotone power_zero_id pre_closed pre_expression_test pre_iso sub_mult_closed test_pre tseq2_def while_pre)
  by (smt tseq2_def power_succ_unfold_ext tests_dual.upper_bound_left tests_dual.sub_sup_right_isotone tests_dual.inf_commutative tests_dual.sub_inf_right_isotone pre_closed pre_expression_test pre_iso sub_mult_closed t_seq2_test test_pre tseq2_def while_pre tfun2_def)

lemma t_sum2_below_w:
  "p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ tsum2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) ≤ p⋆x«q"
  by (smt Sum_least pre_closed pre_expression_test t_seq2_below_w t_seq2_test_seq test_pre tsum2_def)

lemma t_sum2_w:
  assumes "aL = 1"
      and "p ∈ Test_expression"
      and "q ∈ Pre_expression"
      and "x ∈ While_program"
    shows "tsum2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) = p⋆x«q"
proof -
  let ?w = "p⋆x«q"
  let ?s = "-p*q⊔p*(x«?w*aL)"
  have "?w = tseq2 (-p*q) p x ?w ?s 0"
    by (smt assms(1-3) tests_dual.sup_right_unit id_def tests_dual.inf_commutative power_zero_id pre_closed pre_expression_test sub_mult_closed test_expression_test tseq2_def while_pre)
  hence "?w ≤ tsum2 (-p*q) p x ?w ?s"
    by (smt assms(2,3) Sum_upper pre_expression_test t_seq2_test_seq test_pre tsum2_def)
  thus ?thesis
    by (smt assms(2-4) tests_dual.antisymmetric pre_closed pre_expression_test t_sum2_test t_sum2_below_w test_pre)
qed

inductive derived_hoare_triple :: "'a ⇒ 'a ⇒ 'a ⇒ bool" ("_ ⦇ _ ⦈ _" [54,54,54] 53)
  where atom_trip:  "p ∈ Pre_expression ⟹ x ∈ Atomic_program ⟹ x«p⦇x⦈p"
      | seq_trip:   "p⦇x⦈q ∧ q⦇y⦈r ⟹ p⦇x*y⦈r"
      | cond_trip:  "p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ p*q⦇x⦈r ∧ -p*q⦇y⦈r ⟹ q⦇x⊲p⊳y⦈r"
      | while_trip: "p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ test_seq t ∧ q ≤ Sum t ⟹ t 0*p*q⦇x⦈aL*q ⟹ (∀n>0 . t n*p*q⦇x⦈pSum t n*q) ⟹ q⦇p⋆x⦈-p*q"
      | cons_trip:  "p ∈ Pre_expression ⟹ s ∈ Pre_expression ⟹ p ≤ q ∧ q⦇x⦈r ⟹ r ≤ s ⟹ p⦇x⦈s"

lemma derived_type:
  "p⦇x⦈q ⟹ p ∈ Pre_expression ∧ q ∈ Pre_expression ∧ x ∈ While_program"
  apply (induct rule: derived_hoare_triple.induct)
  apply (simp add: Pre_expression.pre_pre While_program.atom_prog)
  using While_program.seq_prog apply blast
  using While_program.cond_prog apply blast
  using Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.test_pre While_program.while_prog apply simp
  by blast

lemma cons_pre_trip:
  "p ∈ Pre_expression ⟹ q⦇y⦈r ⟹ p*q⦇y⦈r"
  by (metis cons_trip derived_type Pre_expression.conj_pre pre_expression_test tests_dual.sba_dual.reflexive tests_dual.upper_bound_right)

lemma cons_post_trip:
  "q ∈ Pre_expression ⟹ r ∈ Pre_expression ⟹ p⦇y⦈q*r ⟶ p⦇y⦈r"
  by (metis cons_trip derived_type pre_expression_test tests_dual.sba_dual.reflexive tests_dual.upper_bound_right)

definition valid_hoare_triple :: "'a ⇒ 'a ⇒ 'a ⇒ bool" ("_ ⟨ _ ⟩ _" [54,54,54] 53)
  where "p⟨x⟩q ≡ (p ∈ Pre_expression ∧ q ∈ Pre_expression ∧ x ∈ While_program ∧ p ≤ x«q)"

end

class hoare_calculus_sound = hoare_calculus +
  assumes while_soundness: "-p*-q ≤ x«-q ⟶ aL*-q ≤ -p⋆x«-q"
begin

lemma while_soundness_0:
  "-p*-q ≤ x«-q ⟹ -q*aL ≤ -p⋆x«--p*-q"
  by (smt while_soundness aL_test sub_comm while_post)

lemma while_soundness_1:
  assumes "test_seq t"
      and "-q ≤ Sum t"
      and "t 0*-p*-q ≤ x«aL*-q"
      and "∀n>0 . t n*-p*-q ≤ x«pSum t n*-q"
    shows "-q ≤ -p⋆x«--p*-q"
proof -
  have "∀n . t n*-p*-q ≤ x«-q"
  proof
    fix n
    show "t n*-p*-q ≤ x«-q"
    proof (cases n)
      case 0
      thus ?thesis
        by (smt (z3) assms(1) assms(3) aL_test leq_def pre_closed pre_lower_bound_right test_seq_def tests_dual.sub_associative tests_dual.sub_sup_closed)
    next
      case (Suc m)
      hence 1: "t n*-p*-q ≤ x«pSum t n*-q"
        using assms(4) by blast
      have "x«pSum t n*-q ≤ x«-q"
        by (metis assms(1) pSum_test pre_lower_bound_right)
      thus ?thesis
        using 1 by (smt (verit, del_insts) assms(1) pSum_test pre_closed sub_mult_closed test_seq_def leq_def tests_dual.sub_associative)
    qed
  qed
  hence 2: "-p*-q ≤ x«-q"
    by (smt assms(1,2) Sum_test leq_def mult_right_dist_Sum pre_closed sub_assoc sub_comm sub_mult_closed test_seq_def)
  have "∀n . t n*-q ≤ -p⋆x«--p*-q ∧ pSum t n*-q ≤ -p⋆x«--p*-q"
  proof
    fix n
    show "t n*-q ≤ -p⋆x«--p*-q ∧ pSum t n*-q ≤ -p⋆x«--p*-q"
    proof (induct n rule: nat_less_induct)
      fix n
      assume 3: "∀m<n . t m*-q ≤ -p⋆x«--p*-q ∧ pSum t m*-q ≤ -p⋆x«--p*-q"
      have 4: "pSum t n*-q ≤ -p⋆x«--p*-q"
      proof (cases n)
        case 0
        thus ?thesis
          by (metis pSum.simps(1) pre_closed sub_mult_closed tests_dual.top_greatest tests_dual.sba_dual.less_eq_inf tests_dual.top_double_complement)
      next
        case (Suc m)
        hence "pSum t n*-q = (pSum t m ⊔ t m)*-q"
          by simp
        also have "... = pSum t m*-q ⊔ t m*-q"
          by (metis (full_types) assms(1) pSum_test test_seq_def tests_dual.sup_right_dist_inf)
        also have "... ≤ -p⋆x«--p*-q"
        proof -
          have "pSum t m*-q = --(pSum t m*-q) ∧ t m*-q = --(t m*-q) ∧ -p⋆x«--p*-q = --(-p⋆x«--p*-q)"
            apply (intro conjI)
            apply (metis assms(1) pSum_test tests_dual.sub_sup_closed)
            apply (metis assms(1) test_seq_def tests_dual.sub_sup_closed)
            by (metis pre_closed tests_dual.sub_sup_closed)
          thus ?thesis
            using 3 by (smt (z3) lessI Suc tests_dual.greatest_lower_bound sub_mult_closed)
        qed
        finally show ?thesis
          .
      qed
      hence 5: "x«pSum t n*-q ≤ x«-p⋆x«--p*-q"
        by (smt assms pSum_test pre_closed pre_iso sub_mult_closed)
      have 6: "-p*(t n*-q) ≤ -p*(-p⋆x«--p*-q)"
      proof (cases n)
        case 0
        thus ?thesis
          using 2 by (smt assms(1,3) aL_test leq_def tests_dual.sup_idempotent tests_dual.sub_sup_right_isotone pre_closed pre_lower_bound_left sub_assoc sub_comm sub_mult_closed test_seq_def transitive while_pre_then while_soundness_0)
      next
        case (Suc m)
        hence "-p*(t n*-q) ≤ x«pSum t n*-q"
          by (smt assms(1,4) test_seq_def tests_dual.sub_associative tests_dual.sub_commutative zero_less_Suc)
        hence "-p*(t n*-q) ≤ x«-p⋆x«--p*-q"
          using 5 by (smt assms(1) tests_dual.least_upper_bound pSum_test pre_closed sub_mult_closed test_seq_def leq_def)
        hence "-p*(t n*-q) ≤ -p*(x«-p⋆x«--p*-q)"
          by (smt assms(1) tests_dual.upper_bound_left pre_closed sub_mult_closed test_seq_def leq_def tests_dual.sub_associative)
        thus ?thesis
          using while_post while_pre_then by auto
      qed
      have "--p*(t n*-q) ≤ --p*(-p⋆x«--p*-q)"
        by (smt assms(1) leq_def tests_dual.upper_bound_right sub_assoc sub_comm sub_mult_closed test_seq_def while_pre_else)
      thus "t n*-q ≤ -p⋆x«--p*-q ∧ pSum t n*-q ≤ -p⋆x«--p*-q"
        using 4 6 by (smt assms(1) tests_dual.sup_less_eq_cases_2 pre_closed sub_mult_closed test_seq_def)
    qed
  qed
  thus ?thesis
    by (smt assms(1,2) Sum_test leq_def mult_right_dist_Sum pre_closed sub_comm sub_mult_closed)
qed

lemma while_soundness_2:
  assumes "test_seq t"
      and "-r ≤ Sum t"
      and "∀n . t n*-p ≤ x«pSum t n"
    shows "-r ≤ -p⋆x«1"
proof -
  have 1: "∀n>0 . t n*-p*Sum t ≤ x«pSum t n*Sum t"
    by (smt (z3) assms(1,3) Sum_test Sum_upper leq_def pSum_below_Sum pSum_test test_seq_def tests_dual.sub_associative tests_dual.sub_commutative)
  have 2: "t 0*-p*Sum t ≤ x«bot"
    by (smt assms(1,3) Sum_test Sum_upper leq_def sub_assoc sub_comm test_seq_def pSum.simps(1))
  have "x«bot ≤ x«aL*Sum t"
    by (smt assms(1) Sum_test aL_test pre_iso sub_mult_closed tests_dual.top_double_complement tests_dual.top_greatest)
  hence "t 0*-p*Sum t ≤ x«aL*Sum t"
    using 2 by (smt (z3) assms(1) Sum_test aL_test leq_def pSum.simps(1) pSum_test pre_closed test_seq_def tests_dual.sub_associative tests_dual.sub_sup_closed)
  hence 3: "Sum t ≤ -p⋆x«--p*Sum t"
    using 1 by (smt (verit, del_insts) assms(1) Sum_test tests_dual.sba_dual.one_def tests_dual.sup_right_unit tests_dual.upper_bound_left while_soundness_1)
  have "-p⋆x«--p*Sum t ≤ -p⋆x«1"
    by (metis assms(1) Sum_test pre_below_pre_one tests_dual.sub_sup_closed)
  hence "Sum t ≤ -p⋆x«1"
    using 3 by (smt (z3) assms(1) Sum_test pre_closed tests_dual.sba_dual.one_def while_post tests_dual.transitive)
  thus ?thesis
    by (smt (z3) assms(1,2) Sum_test pre_closed tests_dual.sba_dual.one_def tests_dual.transitive)
qed

theorem soundness:
  "p⦇x⦈q ⟹ p⟨x⟩q"
  apply (induct rule: derived_hoare_triple.induct)
  apply (metis Pre_expression.pre_pre While_program.atom_prog pre_expression_test tests_dual.sba_dual.reflexive valid_hoare_triple_def)
  apply (metis valid_hoare_triple_def pre_expression_test pre_compose While_program.seq_prog)
  apply (metis valid_hoare_triple_def ite_import_mult pre_expression_test cond_prog test_pre)
  apply (smt (verit, del_insts) Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.test_pre While_program.while_prog pre_expression_test valid_hoare_triple_def while_soundness_1)
  by (metis pre_expression_test pre_iso pre_pre tests_dual.sba_dual.transitive valid_hoare_triple_def)

end

class hoare_calculus_pre_complete = hoare_calculus +
  assumes aL_pre_import: "(x«-q)*aL ≤ x«-q*aL"
  assumes pre_right_dist_Sum: "x ∈ While_program ∧ ascending_chain t ∧ test_seq t ⟶ x«Sum t = Sum (λn . x«t n)"
begin

lemma aL_pre_import_equal:
  "(x«-q)*aL = (x«-q*aL)*aL"
proof -
  have 1: "(x«-q)*aL ≤ (x«-q*aL)*aL"
    by (smt (z3) aL_pre_import aL_test pre_closed tests_dual.sub_sup_closed tests_dual.least_upper_bound tests_dual.upper_bound_right)
  have "(x«-q*aL)*aL ≤ (x«-q)*aL"
    by (smt (verit, ccfv_threshold) aL_test pre_closed pre_lower_bound_left tests_dual.sba_dual.inf_isotone tests_dual.sba_dual.reflexive tests_dual.sub_sup_closed)
  thus ?thesis
    using 1 by (smt (z3) tests_dual.antisymmetric aL_test pre_closed tests_dual.sub_sup_closed)
qed

lemma aL_pre_below_t_seq2:
  assumes "p ∈ Test_expression"
      and "q ∈ Pre_expression"
    shows "(p⋆x«q)*aL ≤ tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) 0"
proof (unfold tseq2_def power_zero_id id_def while_pre)
  have "(p⋆x«q)*aL = (p*(x«p⋆x«q) ⊔ -p*q)*aL"
    by (metis assms while_pre test_pre pre_expression_test)
  also have "... = p*(x«p⋆x«q)*aL ⊔ -p*q*aL"
    by (smt (z3) assms aL_test tests_dual.sup_right_dist_inf pre_closed pre_expression_test sub_mult_closed test_pre)
  also have "... = p*((x«p⋆x«q)*aL) ⊔ -p*q*aL"
    by (smt assms aL_test pre_closed pre_expression_test test_pre sub_assoc)
  also have "... ≤ p*(x«(p⋆x«q)*aL) ⊔ -p*q"
  proof -
    have 1: "(x«p⋆x«q)*aL ≤ x«(p⋆x«q)*aL"
      by (metis assms(2) pre_closed pre_expression_test aL_pre_import)
    have "-p*q*aL ≤ -p*q"
      by (metis assms(2) aL_test pre_expression_test tests_dual.sub_sup_closed tests_dual.upper_bound_left)
    thus ?thesis
      using 1 by (smt assms aL_test pre_closed pre_expression_test test_pre tests_dual.sub_sup_closed tests_dual.sub_sup_right_isotone tests_dual.inf_isotone)
  qed
  also have "... = -p*q ⊔ p*(x«(p⋆x«q)*aL)"
    by (smt assms aL_test tests_dual.inf_commutative pre_closed pre_expression_test test_pre tests_dual.sub_sup_closed)
  finally show "(p⋆x«q)*aL ≤ -p*q ⊔ p*(x«(p⋆x«q)*aL)"
    .
qed

lemma t_seq2_ascending:
  assumes "p ∈ Test_expression"
      and "q ∈ Pre_expression"
      and "x ∈ While_program"
    shows "tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) m ≤ tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)) (Suc m)"
proof (induct m)
  let ?w = "p⋆x«q"
  let ?r = "-p*q⊔p*(x«?w*aL)"
  case 0
  have 1: "?w*aL = --(?w*aL)"
    by (simp add: assms Pre_expression.conj_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression pre_expression_test)
  have 2: "?r = --?r"
    by (simp add: assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test)
  have "?w*aL ≤ ?r"
    by (metis aL_pre_below_t_seq2 assms(1,2) id_def tseq2_def power_zero_id)
  hence "?w*aL ≤ ?w*?r"
    using 1 2 by (smt (verit, ccfv_threshold) assms Pre_expression.pre_pre While_program.while_prog aL_test pre_expression_test tests_dual.sub_associative tests_dual.sub_sup_right_isotone tests_dual.sba_dual.less_eq_inf tests_dual.sba_dual.reflexive)
  hence "x«?w*aL ≤ x«(?w*?r)"
    by (smt (verit, ccfv_threshold) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test pre_iso test_pre)
  hence "p*(x«?w*aL) ≤ p*(x«(?w*?r))"
    by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sub_sup_right_isotone)
  hence "?r ≤ -p*q⊔p*(x«(?w*?r))"
    by (smt (verit, del_insts) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sba_dual.reflexive tests_dual.inf_isotone)
  thus ?case
    by (unfold tseq2_def power_zero_id power_succ_unfold_ext id_def tfun2_def)
next
  let ?w = "p⋆x«q"
  let ?r = "-p*q⊔p*(x«?w*aL)"
  let ?t = "tseq2 (-p*q) p x ?w ?r"
  case (Suc m)
  hence "?w*?t m ≤ ?w*?t (Suc m)"
    by (smt (z3) assms(1,2) pre_closed pre_expression_test t_seq2_test test_expression_test tests_dual.sub_sup_right_isotone)
  hence "x«?w*?t m ≤ x«?w*?t (Suc m)"
    by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test pre_iso test_pre tseq2_pre_expression)
  hence "p*(x«?w*?t m) ≤ p*(x«?w*?t (Suc m))"
    by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sub_sup_right_isotone tseq2_pre_expression)
  hence "-p*q⊔p*(x«?w*?t m) ≤ -p*q⊔p*(x«?w*?t (Suc m))"
    by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sba_dual.reflexive tests_dual.inf_isotone tseq2_pre_expression)
  thus ?case
    by (smt tseq2_def power_succ_unfold_ext tfun2_def)
qed

lemma t_seq2_ascending_chain:
  "p ∈ Test_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ ascending_chain (tseq2 (-p*q) p x (p⋆x«q) (-p*q⊔p*(x«(p⋆x«q)*aL)))"
  by (simp add: ord.ascending_chain_def t_seq2_ascending)

end

class hoare_calculus_complete = hoare_calculus_pre_complete +
  assumes while_completeness: "-p*(x«-q) ≤ -q ⟶ -p⋆x«-q ≤ -q⊔aL"
begin

lemma while_completeness_var:
  assumes "-p*(x«-q)⊔-r ≤ -q"
    shows "-p⋆x«-r ≤ -q⊔aL"
proof -
  have 1: "-p⋆x«-q ≤ -q⊔aL"
    by (smt assms pre_closed tests_dual.sub_sup_closed tests_dual.greatest_lower_bound while_completeness)
  have "-p⋆x«-r ≤ -p⋆x«-q"
    by (smt assms pre_closed tests_dual.sub_sup_closed tests_dual.greatest_lower_bound pre_iso)
  thus ?thesis
    using 1 by (smt (z3) aL_test pre_closed tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.transitive)
qed

lemma while_completeness_sum:
  assumes "p ∈ Test_expression"
      and "q ∈ Pre_expression"
      and "x ∈ While_program"
    shows "p⋆x«q ≤ tsum (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
proof -
  let ?w = "p⋆x«q"
  let ?r = "-p*q⊔p*(x«?w*aL)"
  let ?t = "tseq2 (-p*q) p x ?w ?r"
  let ?ts = "tsum2 (-p*q) p x ?w ?r"
  have 1: "?w = --?w"
    by (metis assms(2) pre_expression_test pre_closed)
  have 2: "?r = --?r"
    by (simp add: assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test)
  have 3: "?ts = --?ts"
    by (meson assms(1) assms(2) pre_expression_test t_sum2_test test_expression_test)
  have 4: "test_seq ?t"
    by (simp add: assms(1) assms(2) pre_expression_test t_seq2_test_seq test_expression_test)
  have "-p*q ≤ ?r"
    by (smt (z3) assms(1,2) aL_test pre_closed pre_expression_test sub_mult_closed test_pre tests_dual.lower_bound_left)
  hence 5: "-p*q ≤ ?ts"
    using 1 2 3 by (smt assms Sum_upper id_def tests_dual.sba_dual.transitive power_zero_id pre_expression_test sub_mult_closed test_pre tseq2_def tseq2_test_seq tsum2_def)
  have "∀n . p*(x«?t n) ≤ ?ts"
  proof (rule allI, unfold tsum2_def)
    fix n
    have 6: "p*(x«?t n) ≤ ?t (Suc n)"
      using 4 by (smt assms leq_def power_succ_unfold_ext pre_closed pre_expression_test tests_dual.sub_commutative sub_mult_closed t_seq2_below_w test_pre test_seq_def tfun2_def tseq2_def tests_dual.lower_bound_right)
    have "?t (Suc n) ≤ Sum ?t"
      using 4 Sum_upper by auto
    thus "p*(x«?t n) ≤ Sum ?t"
      using 3 4 6 by (smt assms(1) pre_closed pre_expression_test sub_mult_closed test_pre test_seq_def tests_dual.transitive tsum2_def)
  qed
  hence "p*(x«?ts) ≤ ?ts"
    using 3 4 by (smt assms mult_left_dist_Sum pre_closed pre_right_dist_Sum t_seq2_ascending_chain test_expression_test test_seq_def tsum2_def)
  hence "p*(x«?ts)⊔-p*q ≤ ?ts"
    using 3 5 by (smt assms(1,2) tests_dual.greatest_lower_bound pre_closed pre_expression_test sub_mult_closed test_pre)
  hence "?w ≤ ?ts⊔aL"
    using 1 3 by (smt assms(1,2) pre_expression_test while_post sub_mult_closed t_sum2_below_t_sum t_sum_test test_pre transitive while_completeness_var)
  hence "?w = ?w*(?ts⊔aL)"
    using 1 3 by (smt aL_test tests_dual.sba_dual.less_eq_inf tests_dual.sba_dual.sub_sup_closed)
  also have "... = ?w*?ts⊔?w*aL"
    using 1 3 by (smt aL_test tests_dual.sup_left_dist_inf)
  also have "... ≤ ?ts⊔?t 0"
    using 1 3 4 by (smt (z3) assms(1,2) aL_pre_below_t_seq2 tests_dual.upper_bound_right aL_test test_seq_def tests_dual.sub_sup_closed tests_dual.inf_isotone)
  also have "... = ?ts"
    using 3 4 by (smt Sum_upper tsum2_def test_seq_def tests_dual.less_eq_inf)
  finally have "?w ≤ ?ts"
    .
  thus ?thesis
    using 1 3 by (metis assms t_sum2_below_t_sum t_sum2_below_w tests_dual.antisymmetric)
qed

lemma while_complete:
  assumes "p ∈ Test_expression"
      and "q ∈ Pre_expression"
      and "x ∈ While_program"
      and "∀r∈Pre_expression . x«r⦇x⦈r"
    shows "p⋆x«q⦇p⋆x⦈q"
proof -
  let ?w = "p⋆x«q"
  let ?t = "tseq (-p) x ?w (-p⊔(x«?w*aL))"
  have 1: "?w ∈ Pre_expression"
    by (simp add: assms(1-3) Pre_expression.pre_pre While_program.while_prog)
  have 2: "test_seq ?t"
    by (simp add: assms(2) pre_expression_test t_seq_test_seq)
  hence 3: "?w ≤ Sum ?t"
    using assms(1-3) tsum_def while_completeness_sum by auto
  have 4: "p = --p"
    by (simp add: assms(1) test_expression_test)
  have "x«?w*aL = --(x«?w*aL)"
    using 1 by (simp add: assms(3) Pre_expression.conj_pre Pre_expression.pre_pre aL_pre_expression pre_expression_test)
  hence 5: "(-p⊔(x«?w*aL))*p = (x«?w*aL)*p"
    using 4 by (metis tests_dual.sba_dual.inf_complement_intro)
  have "x«aL*?w⦇x⦈aL*?w"
    using 1 by (simp add: assms(4) Pre_expression.conj_pre aL_pre_expression)
  hence "x«?w*aL⦇x⦈aL*?w"
    using 1 by (metis aL_test pre_expression_test sub_comm)
  hence "(x«?w*aL)*p*?w⦇x⦈aL*?w"
    using 1 by (smt (z3) assms(1) Pre_expression.conj_pre Pre_expression.test_pre derived_hoare_triple.cons_trip derived_type pre_expression_test sub_assoc tests_dual.sba_dual.reflexive tests_dual.upper_bound_left)
  hence "(-p⊔(x«?w*aL))*p*?w⦇x⦈aL*?w"
    using 5 by simp
  hence 6: "?t 0*p*?w⦇x⦈aL*?w"
    by (unfold tseq_def power_zero_id id_def)
  have "∀n>0 . ?t n*p*?w⦇x⦈pSum ?t n*?w"
  proof (rule allI, rule impI)
    fix n
    assume "0<(n::nat)"
    from this obtain m where 7: "n = Suc m"
      by (auto dest: less_imp_Suc_add)
    hence "?t m*?w ≤ pSum ?t n*?w"
      using 1 2 by (smt pSum.simps(2) pSum_test pre_expression_test test_seq_def tests_dual.lower_bound_right tests_dual.sba_dual.inf_isotone tests_dual.sba_dual.reflexive)
    thus "?t n*p*?w⦇x⦈pSum ?t n*?w"
      using 1 7 by (smt assms conj_pre cons_trip tests_dual.upper_bound_left tests_dual.sba_dual.inf_complement_intro pSum_pre_expression power_succ_unfold_ext pre_closed pre_expression_test sub_assoc sub_comm t_seq_pre_expression test_pre tfun_def tseq_def)
  qed
  hence "?w⦇p⋆x⦈-p*?w"
    using 1 2 3 6 assms while_trip by auto
  hence "?w⦇p⋆x⦈-p*q"
    using 4 by (metis assms(2) while_pre_else pre_expression_test while_pre_else)
  thus ?thesis
    using assms(1,2) Pre_expression.neg_pre Pre_expression.test_pre cons_post_trip by blast
qed

lemma pre_completeness:
  "x ∈ While_program ⟹ q ∈ Pre_expression ⟹ x«q⦇x⦈q"
  apply (induct arbitrary: q rule: While_program.induct)
  apply (simp add: derived_hoare_triple.atom_trip)
  apply (metis pre_pre pre_seq seq_trip pre_expression_test)
  apply (smt cond_prog cond_trip cons_pre_trip ite_pre_else ite_pre_then neg_pre pre_pre pre_expression_test test_pre)
  by (simp add: while_complete)

theorem completeness:
  "p⟨x⟩q ⟹ p⦇x⦈q"
  by (metis valid_hoare_triple_def pre_completeness tests_dual.reflexive pre_expression_test cons_trip)

end

class hoare_calculus_sound_complete = hoare_calculus_sound + hoare_calculus_complete
begin

text ‹Theorem 41›

theorem soundness_completeness:
  "p⦇x⦈q ⟷ p⟨x⟩q"
  using completeness soundness by blast

end

class hoare_rules = whiledo + complete_tests + hoare_triple +
  assumes rule_pre:   "x«-q⦃x⦄-q"
  assumes rule_seq:   "-p⦃x⦄-q ∧ -q⦃y⦄-r ⟶ -p⦃x*y⦄-r"
  assumes rule_cond:  "-p*-q⦃x⦄-r ∧ --p*-q⦃y⦄-r ⟶ -q⦃x⊲-p⊳y⦄-r"
  assumes rule_while: "test_seq t ∧ -q ≤ Sum t ∧ t 0*-p*-q⦃x⦄aL*-q ∧ (∀n>0 . t n*-p*-q⦃x⦄pSum t n*-q) ⟶ -q⦃-p⋆x⦄--p*-q"
  assumes rule_cons:  "-p ≤ -q ∧ -q⦃x⦄-r ∧ -r ≤ -s ⟶ -p⦃x⦄-s"
  assumes rule_disj:  "-p⦃x⦄-r ∧ -q⦃x⦄-s ⟶ -p⊔-q⦃x⦄-r⊔-s"
begin

lemma rule_cons_pre:
  "-p ≤ -q ⟹ -q⦃x⦄-r ⟹ -p⦃x⦄-r"
  using rule_cons tests_dual.sba_dual.reflexive by blast

lemma rule_cons_pre_mult:
  "-q⦃x⦄-r ⟹ -p*-q⦃x⦄-r"
  by (metis tests_dual.sub_sup_closed rule_cons_pre tests_dual.upper_bound_right)

lemma rule_cons_pre_plus:
  "-p⊔-q⦃x⦄-r ⟹ -p⦃x⦄-r"
  by (metis tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.upper_bound_left rule_cons_pre)

lemma rule_cons_post:
  "-q⦃x⦄-r ⟹ -r ≤ -s ⟹ -q⦃x⦄-s"
  using rule_cons tests_dual.sba_dual.reflexive by blast

lemma rule_cons_post_mult:
  "-q⦃x⦄-r*-s ⟹ -q⦃x⦄-s"
  by (metis rule_cons_post tests_dual.upper_bound_left sub_comm sub_mult_closed)

lemma rule_cons_post_plus:
  "-q⦃x⦄-r ⟹ -q⦃x⦄-r⊔-s"
  by (metis tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.upper_bound_left rule_cons_post)

lemma rule_disj_pre:
 "-p⦃x⦄-r ⟹ -q⦃x⦄-r ⟹ -p⊔-q⦃x⦄-r"
  by (metis rule_disj tests_dual.sba_dual.sup_idempotent)

end

class hoare_calculus_valid = hoare_calculus_sound_complete + hoare_triple +
  assumes hoare_triple_valid: "-p⦃x⦄-q ⟷ -p ≤ x«-q"
begin

lemma valid_hoare_triple_same:
  "p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ p⦃x⦄q = p⟨x⟩q"
  by (metis valid_hoare_triple_def hoare_triple_valid pre_expression_test)

lemma derived_hoare_triple_same:
  "p ∈ Pre_expression ⟹ q ∈ Pre_expression ⟹ x ∈ While_program ⟹ p⦃x⦄q = p⦇x⦈q"
  by (simp add: soundness_completeness valid_hoare_triple_same)

lemma valid_rule_disj:
  assumes "-p⦃x⦄-r"
      and "-q⦃x⦄-s"
    shows "-p⊔-q⦃x⦄-r⊔-s"
proof -
  have "x«-r ≤ x«-r⊔-s ∧ x«-s ≤ x«-r⊔-s"
    by (metis pre_iso tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.upper_bound_left tests_dual.sba_dual.upper_bound_right)
  thus ?thesis
    by (smt assms hoare_triple_valid tests_dual.greatest_lower_bound tests_dual.sba_dual.sub_sup_closed pre_closed tests_dual.transitive)
qed

subclass hoare_rules
  apply unfold_locales
  apply (metis hoare_triple_valid pre_closed tests_dual.sba_dual.reflexive)
  apply (meson hoare_triple_valid pre_compose)
  apply (smt hoare_triple_valid ite_import_mult sub_mult_closed)
  apply (smt (verit, del_insts) hoare_triple_valid aL_test pSum_test sba_dual.sub_sup_closed sub_mult_closed test_seq_def while_soundness_1)
  apply (smt hoare_triple_valid pre_iso tests_dual.transitive pre_closed)
  by (simp add: valid_rule_disj)

lemma nat_test_rule_while:
  "nat_test t s ⟹ -q ≤ s ⟹ (∀n . t n*-p*-q⦃x⦄pSum t n*-q) ⟹ -q⦃-p⋆x⦄--p*-q"
  by (smt (verit, ccfv_threshold) hoare_triple_valid nat_test_def nat_test_pre pSum_test_nat sub_mult_closed)

lemma test_seq_rule_while:
  "test_seq t ⟹ -q ≤ Sum t ⟹ t 0*-p*-q⦃x⦄aL*-q ⟹ (∀n>0 . t n*-p*-q⦃x⦄pSum t n*-q) ⟹ -q⦃-p⋆x⦄--p*-q"
  by (smt (verit, del_insts) hoare_triple_valid aL_test pSum_test sub_mult_closed test_seq_def while_soundness_1)

lemma rule_bot:
  "bot⦃x⦄-p"
  by (metis hoare_triple_valid pre_closed tests_dual.top_double_complement tests_dual.top_greatest)

lemma rule_skip:
  "-p⦃1⦄-p"
  by (simp add: hoare_triple_valid pre_one_increasing)

lemma rule_example_4:
  assumes "test_seq t"
      and "Sum t = 1"
      and "t 0*-p1*-p3 = bot"
      and "-p1⦃z1⦄-p1*-p2"
      and "∀n>0 . t n*-p1*-p2*-p3⦃z2⦄pSum t n*-p1*-p2"
    shows "-p1⦃z1*(-p3⋆z2)⦄-p2*--p3"
proof -
  have "t 0*-p3*(-p1*-p2) = bot"
    by (smt (verit, ccfv_threshold) assms(1,3) sub_assoc sub_comm sub_mult_closed test_seq_def tests_dual.sup_right_zero)
  hence 1: "t 0*-p3*(-p1*-p2)⦃z2⦄aL*(-p1*-p2)"
    by (metis aL_test sub_mult_closed rule_bot)
  have "∀n>0 . t n*-p3*(-p1*-p2)⦃z2⦄pSum t n*(-p1*-p2)"
    by (smt assms(1,5) lower_bound_left pSum_test rule_cons_pre sub_assoc sub_comm sub_mult_closed test_seq_def)
  hence "-p1*-p2⦃-p3⋆z2⦄--p3*(-p1*-p2)"
    using 1 by (smt (verit, del_insts) assms(1,2) tests_dual.sub_bot_least rule_while sub_mult_closed)
  thus ?thesis
    by (smt assms(4) tests_dual.upper_bound_left rule_cons_post rule_seq sub_assoc sub_comm sub_mult_closed)
qed

end

class hoare_calculus_pc_2 = hoare_calculus_sound + hoare_calculus_pre_complete +
  assumes aL_one: "aL = 1"
begin

subclass hoare_calculus_sound_complete
  apply unfold_locales
  by (simp add: aL_one pre_below_one)

lemma while_soundness_pc:
  assumes "-p*-q ≤ x«-q"
  shows "-q ≤ -p⋆x«--p*-q"
proof -
  let ?t = "λx . 1"
  have 1: "test_seq ?t"
    by (simp add: test_seq_def)
  hence 2: "-q ≤ Sum ?t"
    by (metis Sum_test Sum_upper tests_dual.sba_dual.one_def tests_dual.antisymmetric tests_dual.sub_bot_least)
  have 3: "?t 0*-p*-q ≤ x«aL*-q"
    using 1 by (simp add: assms aL_one)
  have "∀n>0 . ?t n*-p*-q ≤ x«pSum ?t n*-q"
    using 1 by (metis assms pSum_test pSum_upper tests_dual.sba_dual.one_def tests_dual.antisymmetric tests_dual.sub_bot_least tests_dual.sup_left_unit)
  thus ?thesis
    using 1 2 3 aL_one while_soundness_0 by auto
qed

end

class hoare_calculus_pc = hoare_calculus_sound + hoare_calculus_pre_complete +
  assumes pre_one_one: "x«1 = 1"
begin

subclass hoare_calculus_pc_2
  apply unfold_locales
  by (simp add: aL_def pre_one_one)

end

class hoare_calculus_pc_valid = hoare_calculus_pc + hoare_calculus_valid
begin

lemma rule_while_pc:
  "-p*-q⦃x⦄-q ⟹ -q⦃-p⋆x⦄--p*-q"
  by (metis hoare_triple_valid sub_mult_closed while_soundness_pc)

lemma rule_alternation:
  "-p⦃x⦄-q ⟹ -q⦃y⦄-p ⟹ -p⦃-r⋆x*y⦄--r*-p"
  by (meson rule_cons_pre_mult rule_seq rule_while_pc)

lemma rule_alternation_context:
  "-p⦃v⦄-p ⟹ -p⦃w⦄-q ⟹ -q⦃x⦄-q ⟹ -q⦃y⦄-p ∧ -p⦃z⦄-p ⟹ -p⦃-r⋆v*w*x*y*z⦄--r*-p"
  by (meson rule_cons_pre_mult rule_seq rule_while_pc)

lemma rule_example_3:
  assumes "-p*-q⦃x⦄--p*-q"
      and "--p*-r⦃x⦄-p*-r"
      and "-p*-r⦃y⦄-p*-q"
      and "--p*-q⦃z⦄--p*-r"
    shows "-p*-q⊔--p*-r⦃-s⋆x*(y⊲-p⊳z)⦄--s*(-p*-q⊔--p*-r)"
proof -
  have t1: "-p*-q⊔--p*-r⦃x⦄--p*-q⊔-p*-r"
    by (smt assms(1,2) rule_disj sub_mult_closed)
  have "-p*-r⦃y⦄-p*-q⊔--p*-r"
    by (smt assms(3) rule_cons_post_plus sub_mult_closed)
  hence t2: "-p*(--p*-q⊔-p*-r)⦃y⦄-p*-q⊔--p*-r"
    by (smt (z3) tests_dual.sba_dual.less_eq_inf tests_dual.sba_dual.reflexive tests_dual.sba_dual.sub_sup_closed tests_dual.sub_associative tests_dual.sub_sup_closed tests_dual.upper_bound_left tests_dual.wnf_lemma_3)
  have "--p*-q⦃z⦄-p*-q⊔--p*-r"
    by (smt assms(4) tests_dual.inf_commutative rule_cons_post_plus sub_mult_closed)
  hence "--p*(--p*-q⊔-p*-r)⦃z⦄-p*-q⊔--p*-r"
    by (smt (z3) tests_dual.sba_dual.one_def tests_dual.sba_dual.sup_absorb tests_dual.sba_dual.sup_complement_intro tests_dual.sba_dual.sup_right_unit tests_dual.sub_sup_closed tests_dual.sup_complement_intro tests_dual.sup_left_dist_inf tests_dual.sup_right_unit tests_dual.top_double_complement)
  hence "--p*-q⊔-p*-r⦃y⊲-p⊳z⦄-p*-q⊔--p*-r"
    using t2 by (smt tests_dual.inf_closed rule_cond sub_mult_closed)
  hence "-s*(-p*-q⊔--p*-r)⦃x*(y⊲-p⊳z)⦄-p*-q⊔--p*-r"
    using t1 by (smt tests_dual.inf_closed rule_cons_pre_mult rule_seq sub_mult_closed)
  thus ?thesis
    by (smt tests_dual.inf_closed rule_while_pc sub_mult_closed)
qed

end

class hoare_calculus_tc = hoare_calculus + precondition_test_test + precondition_distr_mult +
  assumes while_bnd: "p ∈ Test_expression ∧ q ∈ Pre_expression ∧ x ∈ While_program ⟶ p⋆x«q ≤ Sum (λn . (p*x)^n«bot)"
begin

lemma
  assumes "p ∈ Test_expression"
      and "q ∈ Pre_expression"
      and "x ∈ While_program"
    shows "p⋆x«q ≤ tsum (-p) x (p⋆x«q) (-p⊔(x«(p⋆x«q)*aL))"
proof -
  let ?w = "p⋆x«q"
  let ?s = "-p⊔(x«?w*aL)"
  let ?t = "tseq (-p) x ?w ?s"
  let ?b = "λn . (p*x)^n«bot"
  have 2: "test_seq ?t"
    by (simp add: assms(2) pre_expression_test t_seq_test_seq)
  have 3: "test_seq ?b"
    using pre_closed test_seq_def tests_dual.sba_dual.complement_top by blast
  have 4: "?w = --?w"
    by (metis assms(2) pre_expression_test pre_closed)
  have "?w ≤ Sum ?b"
    using assms while_bnd by blast
  hence 5: "?w = Sum ?b*?w"
    using 3 4 by (smt Sum_test leq_def sub_comm)
  have "∀n . ?b n*?w ≤ ?t n"
  proof
    fix n
    show "?b n*?w ≤ ?t n"
    proof (induct n)
      show "?b 0*?w ≤ ?t 0"
        using 2 4 by (metis power.power_0 pre_one test_seq_def tests_dual.sup_left_zero tests_dual.top_double_complement tests_dual.top_greatest)
    next
      fix n
      assume 6: "?b n*?w ≤ ?t n"
      have "-p ≤ ?t (Suc n)"
        apply (unfold tseq_def power_succ_unfold_ext)
        by (smt assms(2) pre_expression_test t_seq_test pre_closed sub_mult_closed tfun_def tseq_def tests_dual.lower_bound_left)
      hence 7: "-p*?b (Suc n)*?w ≤ ?t (Suc n)"
        using 2 3 4 by (smt tests_dual.upper_bound_left sub_mult_closed test_seq_def tests_dual.transitive)
      have 8: "p*?b (Suc n)*?w ≤ x«?w*(?b n*?w)"
        by (smt assms(1,2) tests_dual.upper_bound_right tests_dual.sup_idempotent power_Suc pre_closed pre_distr_mult pre_expression_test pre_import_composition sub_assoc sub_comm sub_mult_closed test_expression_test while_pre_then tests_dual.top_double_complement)
      have 9: "... ≤ x«?w*?t n"
        using 2 3 4 6 by (smt tests_dual.sub_sup_right_isotone pre_iso sub_mult_closed test_seq_def)
      have "... ≤ ?t (Suc n)"
        using 2 4 by (smt power_succ_unfold_ext pre_closed sub_mult_closed test_seq_def tfun_def tseq_def tests_dual.lower_bound_right)
      hence "p*?b (Suc n)*?w ≤ ?t (Suc n)"
        using 2 3 4 8 9 by (smt assms(1) pre_closed sub_mult_closed test_expression_test test_seq_def tests_dual.transitive)
      thus "?b (Suc n)*?w ≤ ?t (Suc n)"
        using 2 3 4 7 by (smt assms(1) tests_dual.sup_less_eq_cases sub_assoc sub_mult_closed test_expression_test test_seq_def)
    qed
  qed
  hence "Sum ?b*?w ≤ tsum (-p) x ?w ?s"
    using 3 4 by (smt assms(2) Sum_upper mult_right_dist_Sum pre_expression_test sub_mult_closed t_seq_test t_sum_test test_seq_def tests_dual.transitive tsum_def)
  thus ?thesis
    using 5 by auto
qed

end

class complete_pre = complete_tests + precondition + power
begin

definition bnd :: "'a ⇒ 'a"
  where "bnd x ≡ Sup { x^n«bot | n::nat . True }"

lemma bnd_test_set:
  "test_set { x^n«bot | n::nat . True }"
  by (smt (verit, del_insts) CollectD pre_closed test_set_def tests_dual.top_double_complement)

lemma bnd_test:
  "bnd x = --bnd x"
  using bnd_def bnd_test_set sup_test by auto

lemma bnd_upper:
  "x^m«bot ≤ bnd x"
proof -
  have "x^m«bot ∈ { x^m«bot | m::nat . True }"
    by auto
  thus ?thesis
    using bnd_def bnd_test_set sup_upper by auto
qed

lemma bnd_least:
  assumes "∀n . x^n«bot ≤ -p"
    shows "bnd x ≤ -p"
proof -
  have "∀y∈{ x^n«bot | n::nat . True } . y ≤ -p"
    using assms by blast
  thus ?thesis
    using bnd_def bnd_test_set sup_least by auto
qed

lemma mult_right_dist_bnd:
  assumes "∀n . (x^n«bot)*-p ≤ -q"
    shows "bnd x*-p ≤ -q"
proof -
  have "Sup { y*-p | y . y ∈ { x^n«bot | n::nat . True } } ≤ -q"
    by (smt assms mem_Collect_eq tests_dual.complement_bot pre_closed sub_mult_closed sup_least test_set_def)
  thus ?thesis
    using bnd_test_set bnd_def mult_right_dist_sup by simp
qed

lemma tests_complete:
  "nat_test (λn . (-p*x)^n«bot) (bnd(-p*x))"
  using bnd_test bnd_upper mult_right_dist_bnd nat_test_def tests_dual.complement_bot pre_closed by blast

end

end

Theory Hoare_Modal

(* Title:      Hoare Calculus and Modal Operators
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Hoare Calculus and Modal Operators›

theory Hoare_Modal

imports Stone_Kleene_Relation_Algebras.Kleene_Algebras Complete_Domain Hoare Relative_Modal

begin

class box_precondition = relative_box_semiring + pre +
  assumes pre_def: "x«p = |x]p"
begin

text ‹Theorem 47›

subclass precondition
  apply unfold_locales
  apply (simp add: box_x_a pre_def)
  apply (simp add: box_left_mult pre_def)
  using box_def box_right_submult_a_a pre_def tests_dual.sba_dual.greatest_lower_bound apply fastforce
  by (simp add: box_1_a pre_def)

subclass precondition_test_test
  apply unfold_locales
  by (simp add: a_box_a_a pre_def)

subclass precondition_promote
  apply unfold_locales
  using a_mult_d box_def pre_def pre_test_test by auto

subclass precondition_test_box
  apply unfold_locales
  by (simp add: box_a_a d_def pre_def)

lemma pre_Z:
  "-p ≤ x«-q ⟷ -p * x * --q ≤ Z"
  by (simp add: box_demodalisation_2 pre_def)

lemma pre_left_dist_add:
  "x⊔y«-q = (x«-q) * (y«-q)"
  by (simp add: box_left_dist_sup pre_def)

lemma pre_left_antitone:
  "x ≤ y ⟹ y«-q ≤ x«-q"
  by (simp add: box_antitone_isotone pre_def)

lemma pre_promote_neg:
  "(x«-q) * x * --q ≤ Z"
  by (simp add: box_below_Z pre_def)

lemma pre_pc_Z:
  "x«1 = 1 ⟷ x * bot ≤ Z"
  by (simp add: a_strict box_x_1 pre_def)

(*
lemma pre_sub_promote: "(x«-q) * x ≤ (x«-q) * x * -q ⊔ Z" nitpick [expect=genuine,card=6] oops
lemma pre_promote: "(x«-q) * x ⊔ Z = (x«-q) * x * -q ⊔ Z" nitpick [expect=genuine,card=6] oops
lemma pre_mult_sub_promote: "(x*y«-q) * x ≤ (x*y«-q) * x * (y«-q) ⊔ Z" nitpick [expect=genuine,card=6] oops
lemma pre_mult_promote: "(x*y«-q) * x * (y«-q) ⊔ Z = (x*y«-q) * x ⊔ Z" nitpick [expect=genuine,card=6] oops
*)

end

class left_zero_box_precondition = box_precondition + relative_left_zero_antidomain_semiring
begin

lemma pre_sub_promote:
  "(x«-q) * x ≤ (x«-q) * x * -q ⊔ Z"
  using case_split_right_sup pre_promote_neg by blast

lemma pre_promote:
  "(x«-q) * x ⊔ Z = (x«-q) * x * -q ⊔ Z"
  apply (rule sup_same_context)
  apply (simp add: pre_sub_promote)
  by (metis a_below_one le_supI1 mult_1_right mult_right_isotone)

lemma pre_mult_sub_promote:
  "(x*y«-q) * x ≤ (x*y«-q) * x * (y«-q) ⊔ Z"
  by (metis pre_closed pre_seq pre_sub_promote)

lemma pre_mult_promote_sub:
  "(x*y«-q) * x * (y«-q) ≤ (x*y«-q) * x"
  by (metis mult_right_isotone mult_1_right pre_below_one)

lemma pre_mult_promote:
  "(x*y«-q) * x * (y«-q) ⊔ Z = (x*y«-q) * x ⊔ Z"
  by (metis sup_ge1 sup_same_context order_trans pre_mult_sub_promote pre_mult_promote_sub)

end

class diamond_precondition = relative_box_semiring + pre +
  assumes pre_def: "x«p = |x>p"
begin

text ‹Theorem 47›

subclass precondition
  apply unfold_locales
  apply (simp add: d_def diamond_def pre_def)
  apply (simp add: diamond_left_mult pre_def)
  apply (metis a_antitone a_dist_sup box_antitone_isotone box_deMorgan_1 order.refl pre_def sup_right_divisibility)
  by (simp add: diamond_1_a pre_def)

subclass precondition_test_test
  apply unfold_locales
  by (metis diamond_a_a_same diamond_a_export diamond_associative diamond_right_mult pre_def)

subclass precondition_promote
  apply unfold_locales
  using d_def diamond_def pre_def pre_test_test tests_dual.sub_sup_closed by force

subclass precondition_test_diamond
  apply unfold_locales
  by (simp add: diamond_a_a pre_def)

lemma pre_left_dist_add:
  "x⊔y«-q = (x«-q) ⊔ (y«-q)"
  by (simp add: diamond_left_dist_sup pre_def)

lemma pre_left_isotone:
  "x ≤ y ⟹ x«-q ≤ y«-q"
  by (metis diamond_left_isotone pre_def)

end

class box_while = box_precondition + bounded_left_conway_semiring + ite + while +
  assumes ite_def:   "x⊲p⊳y = p * x ⊔ -p * y"
  assumes while_def: "p⋆x = (p * x)⇧^∘ * -p"
begin

subclass bounded_relative_antidomain_semiring ..

lemma Z_circ_left_zero:
  "Z * x⇧^∘ = Z"
  using Z_left_zero_above_one circ_plus_one sup.absorb_iff2 by auto

subclass ifthenelse
  apply unfold_locales
  by (smt a_d_closed box_a_export box_left_dist_sup box_x_a tests_dual.case_duality d_def ite_def pre_def)

text ‹Theorem 48.1›

subclass whiledo
  apply unfold_locales
  apply (smt circ_loop_fixpoint ite_def ite_pre mult_assoc mult_1_right pre_one pre_seq while_def)
  using pre_mult_test_promote while_def by auto

lemma pre_while_1:
  "-p*(-p⋆x)«1 = -p⋆x«1"
proof -
  have "--p*(-p*(-p⋆x)«1) = --p*(-p⋆x«1)"
    by (metis mult_1_right pre_closed pre_seq pre_test_neg tests_dual.sba_dual.top_double_complement while_pre_else)
  thus ?thesis
    by (smt (z3) pre_closed pre_import tests_dual.sba_dual.top_double_complement tests_dual.sup_eq_cases)
qed

lemma aL_one_circ:
  "aL = a(1⇧^∘*bot)"
  by (metis aL_def box_left_mult box_x_a idempotent_bot_closed idempotent_one_closed pre_def tests_dual.sba_dual.one_def while_def tests_dual.one_def)

end

class diamond_while = diamond_precondition + bounded_left_conway_semiring + ite + while +
  assumes ite_def:   "x⊲p⊳y = p * x ⊔ -p * y"
  assumes while_def: "p⋆x = (p * x)⇧^∘ * -p"
begin

subclass bounded_relative_antidomain_semiring ..

lemma Z_circ_left_zero:
  "Z * x⇧^∘ = Z"
  by (simp add: Z_left_zero_above_one circ_reflexive)

subclass ifthenelse
  apply unfold_locales
  by (simp add: ite_def pre_export pre_left_dist_add)

text ‹Theorem 48.2›

subclass whiledo
  apply unfold_locales
  apply (smt circ_loop_fixpoint ite_def ite_pre mult_assoc mult_1_right pre_one pre_seq while_def)
  by (simp add: pre_mult_test_promote while_def)

lemma aL_one_circ:
  "aL = d(1⇧^∘*bot)"
  by (metis aL_def tests_dual.complement_bot diamond_x_1 mult_left_one pre_def while_def)

end

class box_while_program = box_while + atoms
begin

subclass while_program ..

end

class diamond_while_program = diamond_while + atoms
begin

subclass while_program ..

end

class box_hoare_calculus = box_while_program + complete_antidomain_semiring
begin

subclass hoare_calculus ..

end

class diamond_hoare_calculus = diamond_while_program + complete_antidomain_semiring
begin

subclass hoare_calculus ..

end

class box_hoare_sound = box_hoare_calculus + relative_domain_semiring_split + left_kleene_conway_semiring +
  assumes aL_circ: "aL * x⇧^∘ ≤ x⇧^⋆"
begin

lemma aL_circ_ext:
  "|x⇧^⋆]y ≤ |aL * x⇧^∘]y"
  by (simp add: aL_circ box_left_antitone)

lemma box_star_induct:
  assumes "-p ≤ |x](-p)"
    shows "-p ≤ |x⇧^⋆](-p)"
proof -
  have 1: "x*--p*top ≤ Z ⊔ --p*top"
    by (metis assms Z_top sup_commute box_demodalisation_2 mult_assoc mult_left_isotone shunting_Z)
  have "x*(Z ⊔ --p*top) ≤ x*--p*top ⊔ Z"
    using split_Z sup_monoid.add_commute mult_assoc by force
  also have "... ≤ Z ⊔ --p*top"
    using 1 by simp
  finally have "x*(Z ⊔ --p*top) ⊔ --p ≤ Z ⊔ --p*top"
    using le_supI2 sup.bounded_iff top_right_mult_increasing by auto
  thus ?thesis
    by (metis sup_commute box_demodalisation_2 mult_assoc shunting_Z star_left_induct)
qed

lemma box_circ_induct:
  "-p ≤ |x](-p) ⟹ -p*aL ≤ |x⇧^∘](-p)"
  by (smt aL_circ_ext aL_test box_left_mult box_star_induct order_trans tests_dual.inf_commutative pre_closed pre_def pre_test tests_dual.shunting_right)

lemma a_while_soundness:
  assumes "-p*-q ≤ |x](-q)"
    shows "aL*-q ≤ |(-p*x)⇧^∘*--p](-q)"
proof -
  have "|(-p*x)⇧^∘](-q) ≤ |(-p*x)⇧^∘*--p](-q)"
    by (meson box_left_antitone circ_mult_upper_bound circ_reflexive order.refl order.trans tests_dual.sub_bot_least)
  thus ?thesis
    by (smt assms box_import_shunting box_circ_induct order_trans sub_comm aL_test)
qed

subclass hoare_calculus_sound
  apply unfold_locales
  by (simp add: a_while_soundness pre_def while_def)

end

class diamond_hoare_sound = diamond_hoare_calculus + left_kleene_conway_semiring +
  assumes aL_circ: "aL * x⇧^∘ ≤ x⇧^⋆"
begin

lemma aL_circ_equal:
  "aL * x⇧^∘ = aL * x⇧^⋆"
  apply (rule order.antisym)
  using aL_circ aL_one_circ d_restrict_iff_1 apply force
  by (simp add: mult_right_isotone star_below_circ)

lemma aL_zero:
  "aL = bot"
  by (smt aL_circ_equal aL_one_circ d_export d_idempotent diamond_d_bot diamond_def mult_assoc mult_1_right star_one)

subclass hoare_calculus_sound
  apply unfold_locales
  using aL_zero by auto

end

class box_hoare_complete = box_hoare_calculus + left_kleene_conway_semiring +
  assumes box_circ_induct_2: "-p*|x](-q) ≤ -q ⟶ |x⇧^∘](-p) ≤ -q⊔aL"
  assumes aL_zero_or_one: "aL = bot ∨ aL = 1"
  assumes while_mult_left_dist_Prod: "x ∈ While_program ∧ descending_chain t ∧ test_seq t ⟶ x*Prod t = Prod (λn . x*t n)"
begin

subclass hoare_calculus_complete
  apply unfold_locales
  apply (metis aL_zero_or_one bot_least order.eq_iff mult_1_right pre_closed tests_dual.sup_right_zero)
  subgoal
    apply (unfold pre_def box_def)
    by (metis a_ascending_chain a_dist_Prod a_dist_Sum descending_chain_left_mult while_mult_left_dist_Prod test_seq_def)
  by (smt box_circ_induct_2 tests_dual.double_negation tests_dual.greatest_lower_bound tests_dual.upper_bound_left mult_right_dist_sup pre_closed pre_def pre_import pre_seq pre_test sub_mult_closed while_def)

end

class diamond_hoare_complete = diamond_hoare_calculus + relative_domain_semiring_split + left_kleene_conway_semiring +
  assumes dL_circ: "-aL*x⇧^∘ ≤ x⇧^⋆"
  assumes aL_zero_or_one: "aL = bot ∨ aL = 1"
  assumes while_mult_left_dist_Sum: "x ∈ While_program ∧ ascending_chain t ∧ test_seq t ⟶ x*Sum t = Sum (λn . x*t n)"
begin

lemma diamond_star_induct_var:
  assumes "|x>(d p) ≤ d p"
    shows "|x⇧^⋆>(d p) ≤ d p"
proof -
  have "x * (d p * x⇧^⋆ ⊔ Z) ≤ d p * x * x⇧^⋆ ⊔ Z * x⇧^⋆ ⊔ Z"
    by (metis assms sup_left_isotone d_mult_d diamond_def diamond_demodalisation_3 mult_assoc mult_left_isotone mult_right_dist_sup order_trans split_Z)
  also have "... ≤ d p * x⇧^⋆ ⊔ Z"
    by (metis Z_mult_decreasing mult_right_isotone star.left_plus_below_circ sup.bounded_iff sup_ge1 sup_mono sup_monoid.add_commute mult_assoc)
  finally show ?thesis
    by (smt sup_commute le_sup_iff sup_ge2 d_mult_d diamond_def diamond_demodalisation_3 order_trans star.circ_back_loop_prefixpoint star_left_induct)
qed

lemma diamond_star_induct:
  "d q ⊔ |x>(d p) ≤ d p ⟹ |x⇧^⋆>(d q) ≤ d p"
  by (metis le_sup_iff diamond_star_induct_var diamond_right_isotone order_trans)

lemma while_completeness_1:
  assumes "-p*(x«-q) ≤ -q"
    shows "-p⋆x«-q ≤ -q⊔aL"
proof -
  have "--p*-q ⊔ |-p*x>(-q) ≤ -q"
    using assms pre_def pre_export tests_dual.upper_bound_right by auto
  hence "|(-p*x)⇧^⋆>(--p*-q) ≤ -q"
    by (smt diamond_star_induct d_def sub_mult_closed tests_dual.double_negation)
  hence "|-aL*(-p*x)⇧^∘>(--p*-q) ≤ -q"
    by (meson dL_circ diamond_isotone order.eq_iff order.trans)
  thus ?thesis
    by (smt aL_test diamond_a_export diamond_def mult_assoc tests_dual.inf_commutative pre_closed pre_def tests_dual.shunting while_def)
qed

subclass hoare_calculus_complete
  apply unfold_locales
  apply (metis aL_test aL_zero_or_one bot_least order.eq_iff pre_closed pre_test pre_test_one tests_dual.sup_right_zero)
  subgoal
    apply (unfold pre_def diamond_def)
    by (simp add: ascending_chain_left_mult d_dist_Sum while_mult_left_dist_Sum)
  by (simp add: while_completeness_1)

end

class box_hoare_valid = box_hoare_sound + box_hoare_complete + hoare_triple +
  assumes hoare_triple_def: "p⦃x⦄q ⟷ p ≤ |x]q"
begin

text ‹Theorem 49.2›

subclass hoare_calculus_valid
  apply unfold_locales
  by (simp add: hoare_triple_def pre_def)

lemma rule_skip_valid:
  "-p⦃1⦄-p"
  by (simp add: rule_skip)

end

class diamond_hoare_valid = diamond_hoare_sound + diamond_hoare_complete + hoare_triple +
  assumes hoare_triple_def: "p⦃x⦄q ⟷ p ≤ |x>q"
begin

lemma circ_star_equal:
  "x⇧^∘ = x⇧^⋆"
  by (metis aL_zero order.antisym dL_circ mult_left_one one_def star_below_circ)

text ‹Theorem 49.1›

subclass hoare_calculus_valid
  apply unfold_locales
  by (simp add: hoare_triple_def pre_def)

end

class diamond_hoare_sound_2 = diamond_hoare_calculus + left_kleene_conway_semiring +
  assumes diamond_circ_induct_2: "--p*-q ≤ |x>(-q) ⟶  aL*-q ≤ |x⇧^∘>(-p)"
begin

subclass hoare_calculus_sound
  apply unfold_locales
  by (smt a_export diamond_associative diamond_circ_induct_2 tests_dual.double_negation tests_dual.sup_complement_intro pre_def pre_import_equiv_mult sub_comm sub_mult_closed while_def)

end

class diamond_hoare_valid_2 = diamond_hoare_sound_2 + diamond_hoare_complete + hoare_triple +
  assumes hoare_triple_def: "p⦃x⦄q ⟷ p ≤ |x>q"
begin

subclass hoare_calculus_valid
  apply unfold_locales
  by (simp add: hoare_triple_def pre_def)

end

end

Theory Pre_Post

(* Title:      Pre-Post Specifications
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Pre-Post Specifications›

theory Pre_Post

imports Preconditions

begin

class pre_post =
  fixes pre_post :: "'a ⇒ 'a ⇒ 'a" (infix "⊣" 55)

class pre_post_spec_greatest = bounded_idempotent_left_semiring + precondition + pre_post +
  assumes pre_post_galois: "-p ≤ x«-q ⟷ x ≤ -p⊣-q"
begin

text ‹Theorem 42.1›

lemma post_pre_left_antitone:
  "x ≤ y ⟹ y«-q ≤ x«-q"
  by (smt order_refl order_trans pre_closed pre_post_galois)

lemma pre_left_sub_dist:
  "x⊔y«-q ≤ x«-q"
  by (simp add: post_pre_left_antitone)

text ‹Theorem 42.2›

lemma pre_post_left_antitone:
  "-p ≤ -q ⟹ -q⊣-r ≤ -p⊣-r"
  using order_lesseq_imp pre_post_galois by blast

lemma pre_post_left_sub_dist:
  "-p⊔-q⊣-r ≤ -p⊣-r"
  by (metis sup.cobounded1 tests_dual.sba_dual.sub_sup_closed pre_post_left_antitone)

lemma pre_post_left_sup_dist:
  "-p⊣-r ≤ -p*-q⊣-r"
  by (metis tests_dual.sba_dual.sub_inf_def pre_post_left_sub_dist tests_dual.inf_absorb)

text ‹Theorem 42.5›

lemma pre_pre_post:
  "x ≤ (x«-p)⊣-p"
  by (metis order_refl pre_closed pre_post_galois)

text ‹Theorem 42.6›

lemma pre_post_pre:
  "-p ≤ (-p⊣-q)«-q"
  by (simp add: pre_post_galois)

text ‹Theorem 42.8›

lemma pre_post_zero_top:
  "bot⊣-q = top"
  by (metis order.eq_iff pre_post_galois sup.cobounded2 sup_monoid.add_0_right top_greatest tests_dual.top_double_complement)

text ‹Theorem 42.7›

lemma pre_post_pre_one:
  "(1⊣-q)«-q = 1"
  by (metis order.eq_iff pre_below_one tests_dual.sba_dual.top_double_complement pre_post_pre)

text ‹Theorem 42.3›

lemma pre_post_right_isotone:
  "-p ≤ -q ⟹ -r⊣-p ≤ -r⊣-q"
  using order_lesseq_imp pre_iso pre_post_galois by blast

lemma pre_post_right_sub_dist:
  "-r⊣-p ≤ -r⊣-p⊔-q"
  by (metis sup.cobounded1 tests_dual.sba_dual.sub_sup_closed pre_post_right_isotone)

lemma pre_post_right_sup_dist:
  "-r⊣-p*-q ≤ -r⊣-p"
  by (metis tests_dual.sub_sup_closed pre_post_right_isotone tests_dual.upper_bound_left)

text ‹Theorem 42.7›

lemma pre_post_reflexive:
  "1 ≤ -p⊣-p"
  using pre_one_increasing pre_post_galois by auto

text ‹Theorem 42.9›

lemma pre_post_compose:
  "-q ≤ -r ⟹ (-p⊣-q)*(-r⊣-s) ≤ -p⊣-s"
  using order_lesseq_imp pre_compose pre_post_galois by blast

text ‹Theorem 42.10›

lemma pre_post_compose_1:
  "(-p⊣-q)*(-q⊣-r) ≤ -p⊣-r"
  by (simp add: pre_post_compose)

text ‹Theorem 42.11›

lemma pre_post_compose_2:
  "(-p⊣-p)*(-p⊣-q) = -p⊣-q"
  by (meson case_split_left order.eq_iff le_supI1 pre_post_compose_1 pre_post_reflexive)

text ‹Theorem 42.12›

lemma pre_post_compose_3:
  "(-p⊣-q)*(-q⊣-q) = -p⊣-q"
  by (meson order.eq_iff order.trans mult_right_isotone mult_sub_right_one pre_post_compose_1 pre_post_reflexive)

text ‹Theorem 42.13›

lemma pre_post_compose_4:
  "(-p⊣-p)*(-p⊣-p) = -p⊣-p"
  by (simp add: pre_post_compose_3)

text ‹Theorem 42.14›

lemma pre_post_one_one:
  "x«1 = 1 ⟷ x ≤ 1⊣1"
  by (metis order.eq_iff one_def pre_below_one pre_post_galois)

text ‹Theorem 42.4›

lemma post_pre_left_dist_sup:
  "x⊔y«-q = (x«-q)*(y«-q)"
  apply (rule order.antisym)
  apply (metis mult_isotone pre_closed sup_commute tests_dual.sup_idempotent pre_left_sub_dist)
  by (smt (z3) order.refl pre_closed pre_post_galois sup.boundedI tests_dual.sba_dual.greatest_lower_bound tests_dual.sub_sup_closed)

(*
lemma pre_post_right_dist_sup: "-p⊣-q⊔-r = (-p⊣-q) ⊔ (-p⊣-r)" nitpick [expect=genuine,card=4] oops
*)

end

class pre_post_spec_greatest_2 = pre_post_spec_greatest + precondition_test_test
begin

subclass precondition_test_box
  apply unfold_locales
  by (smt (verit) sup_commute mult_1_right tests_dual.double_negation order.eq_iff mult_left_one mult_right_dist_sup one_def tests_dual.inf_complement tests_dual.inf_complement_intro pre_below_one pre_import pre_post_galois pre_test_test tests_dual.top_def bot_least)

lemma pre_post_seq_sub_associative:
  "(-p⊣-q)*-r ≤ -p⊣-q*-r"
  by (smt (z3) pre_compose pre_post_galois pre_post_pre sub_comm test_below_pre_test_mult tests_dual.sub_sup_closed)

lemma pre_post_right_import_mult:
  "(-p⊣-q)*-r = (-p⊣-q*-r)*-r"
  by (metis order.antisym mult_assoc tests_dual.sup_idempotent mult_left_isotone pre_post_right_sup_dist pre_post_seq_sub_associative)

lemma seq_pre_post_sub_associative:
  "-r*(-p⊣-q) ≤ --r⊔-p⊣-q"
  by (smt (z3) pre_compose pre_post_galois pre_post_pre pre_test tests_dual.sba_dual.reflexive tests_dual.sba_dual.sub_sup_closed)

lemma pre_post_left_import_sup:
  "-r*(-p⊣-q) = -r*(--r⊔-p⊣-q)"
  by (metis sup_commute order.antisym mult_assoc tests_dual.sup_idempotent mult_right_isotone pre_post_left_sub_dist seq_pre_post_sub_associative)

lemma pre_post_import_same:
  "-p*(-p⊣-q) = -p*(1⊣-q)"
  using pre_test pre_test_test_same pre_post_left_import_sup by auto

lemma pre_post_import_complement:
  "--p*(-p⊣-q) = --p*top"
  by (metis tests_dual.sup_idempotent tests_dual.inf_cases tests_dual.inf_closed pre_post_left_import_sup pre_post_zero_top tests_dual.top_def tests_dual.top_double_complement)

lemma pre_post_export:
  "-p⊣-q = (1⊣-q) ⊔ --p*top"
proof (rule order.antisym)
  have 1: "-p*(-p⊣-q) ≤ (1⊣-q) ⊔ --p*top"
    by (metis le_supI1 pre_test pre_test_test_same seq_pre_post_sub_associative)
  have "--p*(-p⊣-q) ≤ (1⊣-q) ⊔ --p*top"
    by (simp add: pre_post_import_complement)
  thus "-p⊣-q ≤ (1⊣-q) ⊔ --p*top"
    using 1 by (smt case_split_left eq_refl tests_dual.inf_complement)
next
  show "(1⊣-q) ⊔ --p*top ≤ -p⊣-q"
    by (metis le_sup_iff tests_dual.double_negation tests_dual.sub_bot_least pre_neg_mult pre_post_galois pre_post_pre_one)
qed

lemma pre_post_left_dist_mult:
  "-p*-q⊣-r = (-p⊣-r) ⊔ (-q⊣-r)"
proof -
  have "∀p q . -p*(-p*-q⊣-r) = -p*(-q⊣-r)"
    using sup_monoid.add_commute tests_dual.sba_dual.sub_inf_def pre_post_left_import_sup tests_dual.inf_complement_intro by auto
  hence 1: "(-p⊔-q)*(-p*-q⊣-r) ≤ (-p⊣-r) ⊔ (-q⊣-r)"
    by (metis sup_commute le_sup_iff sup_ge2 mult_left_one mult_right_dist_sup tests_dual.inf_left_unit sub_comm)
  have "-(-p⊔-q)*(-p*-q⊣-r) = -(-p⊔-q)*top"
    by (smt (z3) sup.left_commute sup_commute tests_dual.sba_dual.sub_sup_closed tests_dual.sub_sup_closed pre_post_import_complement pre_post_left_import_sup tests_dual.inf_absorb)
  hence "-(-p⊔-q)*(-p*-q⊣-r) ≤ (-p⊣-r) ⊔ (-q⊣-r)"
    by (smt (z3) order.trans le_supI1 pre_post_left_sub_dist tests_dual.sba_dual.sub_sup_closed tests_dual.sub_sup_closed seq_pre_post_sub_associative)
  thus ?thesis
    using 1 by (smt (z3) le_sup_iff order.antisym case_split_left order_refl tests_dual.inf_closed tests_dual.inf_complement pre_post_left_sup_dist sub_comm)
qed

lemma pre_post_left_import_mult:
  "-r*(-p⊣-q) = -r*(-r*-p⊣-q)"
  by (metis sup_commute tests_dual.inf_complement_intro pre_post_left_import_sup sub_mult_closed)

lemma pre_post_right_import_sup:
  "(-p⊣-q)*-r = (-p⊣-q⊔--r)*-r"
  by (smt (z3) sup_monoid.add_commute tests_dual.sba_dual.inf_cases_2 tests_dual.sba_dual.inf_complement_intro tests_dual.sub_complement tests_dual.sub_inf_def pre_post_right_import_mult)

lemma pre_post_shunting:
  "x ≤ -p*-q⊣-r ⟷ -p*x ≤ -q⊣-r"
proof -
  have "--p*x ≤ -p*-q⊣-r"
    by (metis tests_dual.double_negation order_trans pre_neg_mult pre_post_galois pre_post_left_sup_dist)
  hence 1: "-p*x ≤ -q⊣-r ⟶ x ≤ -p*-q⊣-r"
    by (smt case_split_left eq_refl order_trans tests_dual.inf_complement pre_post_left_sup_dist sub_comm)
  have "-p*(-p*-q⊣-r) ≤ -q⊣-r"
    by (metis mult_left_isotone mult_left_one tests_dual.sub_bot_least pre_post_left_import_mult)
  thus ?thesis
    using 1 mult_right_isotone order_lesseq_imp by blast
qed

(*
lemma pre_post_right_dist_sup: "-p⊣-q⊔-r = (-p⊣-q) ⊔ (-p⊣-r)" oops
*)

end

class left_zero_pre_post_spec_greatest_2 = pre_post_spec_greatest_2 + bounded_idempotent_left_zero_semiring
begin

lemma pre_post_right_dist_sup:
  "-p⊣-q⊔-r = (-p⊣-q) ⊔ (-p⊣-r)"
proof -
  have 1: "(-p⊣-q⊔-r)*-q ≤ (-p⊣-q) ⊔ (-p⊣-r)"
    by (metis le_supI1 pre_post_seq_sub_associative tests_dual.sba_dual.inf_absorb tests_dual.sba_dual.sub_sup_closed)
  have "(-p⊣-q⊔-r)*--q = (-p⊣-r)*--q"
    by (simp add: pre_post_right_import_sup sup_commute)
  hence "(-p⊣-q⊔-r)*--q ≤ (-p⊣-q) ⊔ (-p⊣-r)"
    by (metis sup_ge2 mult_left_sub_dist_sup_right mult_1_right order_trans tests_dual.inf_left_unit)
  thus ?thesis
    using 1 by (metis le_sup_iff order.antisym case_split_right tests_dual.sub_bot_least tests_dual.inf_commutative tests_dual.inf_complement pre_post_right_sub_dist)
qed

end

class havoc =
  fixes H :: "'a"

class idempotent_left_semiring_H = bounded_idempotent_left_semiring + havoc +
  assumes H_zero : "H * bot = bot"
  assumes H_split: "x ≤ x * bot ⊔ H"
begin

lemma H_galois:
  "x * bot ≤ y ⟷ x ≤ y ⊔ H"
  apply (rule iffI)
  using H_split order_lesseq_imp sup_mono apply blast
  by (smt (verit, ccfv_threshold) H_zero mult_right_dist_sup sup.cobounded2 sup.orderE sup_assoc sup_bot_left sup_commute zero_right_mult_decreasing)

lemma H_greatest_finite:
  "x * bot = bot ⟷ x ≤ H"
  by (metis H_galois le_iff_sup sup_bot_left sup_monoid.add_0_right)

lemma H_reflexive:
  "1 ≤ H"
  using H_greatest_finite mult_left_one by blast

lemma H_transitive:
  "H = H * H"
  by (metis H_greatest_finite H_reflexive H_zero preorder_idempotent mult_assoc)

lemma T_split_H:
  "top * bot ⊔ H = top"
  by (simp add: H_split order.antisym)

(*
lemma "H * (x ⊔ y) = H * x ⊔ H * y" nitpick [expect=genuine,card=6] oops
*)

end

class pre_post_spec_least = bounded_idempotent_left_semiring + precondition_test_test + precondition_promote + pre_post +
  assumes test_mult_right_distr_sup: "-p * (x ⊔ y) = -p * x ⊔ -p * y"
  assumes pre_post_galois: "-p ≤ x«-q ⟷ -p⊣-q ≤ x"
begin

lemma shunting_top:
  "-p * x ≤ y ⟷ x ≤ y ⊔ --p * top"
proof
  assume "-p * x ≤ y"
  thus "x ≤ y ⊔ --p * top"
    by (smt (verit, ccfv_SIG) case_split_left eq_refl le_supI1 le_supI2 mult_right_isotone tests_dual.sba_dual.top_def top_greatest)
next
  assume "x ≤ y ⊔ --p * top"
  hence "-p * x ≤ -p * y"
    by (metis sup_bot_right mult_assoc tests_dual.sup_complement mult_left_zero mult_right_isotone test_mult_right_distr_sup)
  thus "-p * x ≤ y"
    by (metis mult_left_isotone mult_left_one tests_dual.sub_bot_least order_trans)
qed

lemma post_pre_left_isotone:
  "x ≤ y ⟹ x«-q ≤ y«-q"
  by (smt order_refl order_trans pre_closed pre_post_galois)

lemma pre_left_sub_dist:
  "x«-q ≤ x⊔y«-q"
  by (simp add: post_pre_left_isotone)

lemma pre_post_left_isotone:
  "-p ≤ -q ⟹ -p⊣-r ≤ -q⊣-r"
  using order_lesseq_imp pre_post_galois by blast

lemma pre_post_left_sub_dist:
  "-p⊣-r ≤ -p⊔-q⊣-r"
  by (metis sup_ge1 tests_dual.inf_closed pre_post_left_isotone)

lemma pre_post_left_sup_dist:
  "-p*-q⊣-r ≤ -p⊣-r"
  by (metis tests_dual.upper_bound_left pre_post_left_isotone sub_mult_closed)

lemma pre_pre_post:
  "(x«-p)⊣-p ≤ x"
  by (metis order_refl pre_closed pre_post_galois)

lemma pre_post_pre:
  "-p ≤ (-p⊣-q)«-q"
  by (simp add: pre_post_galois)

lemma pre_post_zero_top:
  "bot⊣-q = bot"
  using bot_least order.eq_iff pre_post_galois tests_dual.sba_dual.sub_bot_def by blast

lemma pre_post_pre_one:
  "(1⊣-q)«-q = 1"
  by (metis order.eq_iff pre_below_one pre_post_pre tests_dual.sba_dual.top_double_complement)

lemma pre_post_right_antitone:
  "-p ≤ -q ⟹ -r⊣-q ≤ -r⊣-p"
  using order_lesseq_imp pre_iso pre_post_galois by blast

lemma pre_post_right_sub_dist:
  "-r⊣-p⊔-q ≤ -r⊣-p"
  by (metis sup_ge1 tests_dual.inf_closed pre_post_right_antitone)

lemma pre_post_right_sup_dist:
  "-r⊣-p ≤ -r⊣-p*-q"
  by (metis tests_dual.upper_bound_left pre_post_right_antitone sub_mult_closed)

lemma pre_top:
  "top«-q = 1"
  using order.eq_iff pre_below_one pre_post_galois tests_dual.sba_dual.one_def top_greatest by blast

lemma pre_mult_top_increasing:
  "-p ≤ -p*top«-q"
  using pre_import_equiv pre_top tests_dual.sub_bot_least by auto

lemma pre_post_below_mult_top:
  "-p⊣-q ≤ -p*top"
  using pre_import_equiv pre_post_galois by auto

lemma pre_post_import_complement:
  "--p*(-p⊣-q) = bot"
proof -
  have "--p*(-p⊣-q) ≤ --p*(-p*top)"
    by (simp add: mult_right_isotone pre_post_below_mult_top)
  thus ?thesis
    by (metis mult_assoc mult_left_zero sub_comm tests_dual.top_def order.antisym bot_least)
qed

lemma pre_post_import_same:
  "-p*(-p⊣-q) = -p⊣-q"
proof -
  have "-p⊣-q = -p*(-p⊣-q) ⊔ --p*(-p⊣-q)"
    by (metis mult_left_one mult_right_dist_sup tests_dual.inf_complement)
  thus ?thesis
    using pre_post_import_complement by auto
qed

lemma pre_post_export:
  "-p⊣-q = -p*(1⊣-q)"
proof (rule order.antisym)
  show "-p⊣-q ≤ -p*(1⊣-q)"
    by (metis tests_dual.sub_bot_least pre_import_equiv pre_post_galois pre_post_pre_one)
next
  have 1: "-p ≤ ((-p⊣-q) ⊔ --p*top)«-q"
    by (simp add: pre_post_galois)
  have "--p ≤ ((-p⊣-q) ⊔ --p*top)«-q"
    by (simp add: le_supI2 pre_post_galois pre_post_below_mult_top)
  hence "-p ⊔ --p ≤ ((-p⊣-q) ⊔ --p*top)«-q"
    using 1 le_supI by blast
  hence "1 ≤ ((-p⊣-q) ⊔ --p*top)«-q"
    by simp
  hence "1⊣-q ≤ (-p⊣-q) ⊔ --p*top"
    using pre_post_galois tests_dual.sba_dual.one_def by blast
  thus "-p*(1⊣-q) ≤ -p⊣-q"
    by (simp add: shunting_top)
qed

lemma pre_post_seq_associative:
  "-r*(-p⊣-q) = -r*-p⊣-q"
  by (metis pre_post_export tests_dual.sub_sup_closed mult_assoc)

lemma pre_post_left_import_mult:
  "-r*(-p⊣-q) = -r*(-r*-p⊣-q)"
  by (metis mult_assoc tests_dual.sup_idempotent pre_post_seq_associative)

lemma seq_pre_post_sub_associative:
  "-r*(-p⊣-q) ≤ --r⊔-p⊣-q"
  by (metis le_supI1 pre_post_left_sub_dist sup_commute shunting_top)

lemma pre_post_left_import_sup:
  "-r*(-p⊣-q) = -r*(--r⊔-p⊣-q)"
  by (metis tests_dual.sba_dual.sub_sup_closed pre_post_seq_associative tests_dual.sup_complement_intro)

lemma pre_post_left_dist_sup:
  "-p⊔-q⊣-r = (-p⊣-r) ⊔ (-q⊣-r)"
  by (metis mult_right_dist_sup tests_dual.inf_closed pre_post_export)

lemma pre_post_reflexive:
  "-p⊣-p ≤ 1"
  using pre_one_increasing pre_post_galois by auto

lemma pre_post_compose:
  "-q ≤ -r ⟹ -p⊣-s ≤ (-p⊣-q)*(-r⊣-s)"
  by (meson pre_compose pre_post_galois pre_post_pre pre_post_right_antitone)

lemma pre_post_compose_1:
  "-p⊣-r ≤ (-p⊣-q)*(-q⊣-r)"
  by (simp add: pre_post_compose)

lemma pre_post_compose_2:
  "(-p⊣-p)*(-p⊣-q) = -p⊣-q"
  using order.eq_iff mult_left_isotone pre_post_compose_1 pre_post_reflexive by fastforce

lemma pre_post_compose_3:
  "(-p⊣-q)*(-q⊣-q) = -p⊣-q"
  by (metis order.antisym mult_right_isotone mult_1_right pre_post_compose_1 pre_post_reflexive)

lemma pre_post_compose_4:
  "(-p⊣-p)*(-p⊣-p) = -p⊣-p"
  by (simp add: pre_post_compose_3)

lemma pre_post_one_one:
  "x«1 = 1 ⟷ 1⊣1 ≤ x"
  using order.eq_iff pre_below_one pre_post_galois tests_dual.sub_bot_def by force

lemma pre_one_right:
  "-p«1 = -p"
  by (metis order.antisym mult_1_right one_def tests_dual.inf_complement pre_left_sub_dist pre_mult_top_increasing pre_one pre_seq pre_test_promote pre_top)

lemma pre_pre_one:
  "x«-q = x*-q«1"
  by (metis one_def pre_one_right pre_seq)

subclass precondition_test_diamond
  apply unfold_locales
  using tests_dual.sba_dual.sub_inf_def pre_one_right pre_pre_one by auto

(*
lemma pre_post_shunting: "x ≤ -p*-q⊣-r ⟷ -p*x ≤ -q⊣-r" nitpick [expect=genuine,card=3] oops
lemma "(-p⊣-q)*-r = (-p⊣-q⊔-r)*-r" nitpick [expect=genuine,card=3] oops
lemma "(-p⊣-q)*-r = (-p⊣-q⊔--r)*-r" nitpick [expect=genuine,card=3] oops
lemma "(-p⊣-q)*-r = (-p⊣-q*-r)*-r" nitpick [expect=genuine,card=3] oops
lemma "(-p⊣-q)*-r = (-p⊣-q*--r)*-r" nitpick [expect=genuine,card=3] oops
lemma "-p⊣-q⊔-r = (-p⊣-q) ⊔ (-p⊣-r)" nitpick [expect=genuine,card=3] oops
lemma "-p⊣-q⊔-r = (-p⊣-q) * (-p⊣-r)" nitpick [expect=genuine,card=3] oops
lemma pre_post_right_dist_mult: "-p⊣-q*-r = (-p⊣-q) * (-p⊣-r)" oops
lemma pre_post_right_dist_mult: "-p⊣-q*-r = (-p⊣-q) ⊔ (-p⊣-r)" oops
lemma post_pre_left_dist_sup: "x⊔y«-q = (x«-q) ⊔ (y«-q)" oops
*)

end

class havoc_dual =
  fixes Hd :: "'a"

class idempotent_left_semiring_Hd = bounded_idempotent_left_semiring + havoc_dual +
  assumes Hd_total: "Hd * top = top"
  assumes Hd_least: "x * top = top ⟶ Hd ≤ x"
begin

lemma Hd_least_total:
  "x * top = top ⟷ Hd ≤ x"
  by (metis Hd_least Hd_total order.antisym mult_left_isotone top_greatest)

lemma Hd_reflexive:
  "Hd ≤ 1"
  by (simp add: Hd_least)

lemma Hd_transitive:
  "Hd = Hd * Hd"
  by (simp add: Hd_least Hd_total order.antisym coreflexive_transitive total_mult_closed)

end

class pre_post_spec_least_Hd = idempotent_left_semiring_Hd + pre_post_spec_least +
  assumes pre_one_mult_top: "(x«1)*top = x*top"
begin

lemma Hd_pre_one:
  "Hd«1 = 1"
  by (metis Hd_total pre_seq pre_top)

lemma pre_post_below_Hd:
  "1⊣1 ≤ Hd"
  using Hd_pre_one pre_post_one_one by auto

lemma Hd_pre_post:
  "Hd = 1⊣1"
  by (metis Hd_least Hd_pre_one Hd_total order.eq_iff pre_one_mult_top pre_post_one_one)

lemma top_left_zero:
  "top*x = top"
  by (metis mult_assoc mult_left_one mult_left_zero pre_closed pre_one_mult_top pre_seq pre_top)

lemma test_dual_test:
  "(-p⊔--p*top)*-p = -p⊔--p*top"
  by (simp add: top_left_zero mult_right_dist_sup mult_assoc)

lemma pre_zero_mult_top:
  "(x«bot)*top = x*bot"
  by (metis mult_assoc mult_left_zero one_def pre_one_mult_top pre_seq pre_bot)

lemma pre_one_mult_Hd:
  "(x«1)*Hd ≤ x"
  by (metis Hd_pre_post one_def pre_closed pre_post_export pre_pre_post)

lemma Hd_mult_pre_one:
  "Hd*(x«1) ≤ x"
proof -
  have 1: "-(x«1)*Hd*(x«1) ≤ x"
    by (metis Hd_pre_post le_iff_sup mult_left_isotone pre_closed pre_one_right pre_post_export pre_pre_post sup_commute sup_monoid.add_0_right tests_dual.sba_dual.one_def tests_dual.top_def)
  have "(x«1)*Hd*(x«1) ≤ x"
    by (metis mult_isotone mult_1_right one_def pre_below_one pre_one_mult_Hd)
  thus ?thesis
    using 1 by (metis case_split_left pre_closed reflexive_one_closed tests_dual.sba_dual.one_def tests_dual.sba_dual.top_def mult_assoc)
qed

lemma pre_post_one_def_1:
  assumes "1 ≤ x«-q"
    shows "Hd*(-q⊔--q*top) ≤ x"
proof -
  have "Hd*(-q⊔--q*top) ≤ x*-q*(-q⊔--q*top)"
    by (metis assms Hd_pre_post order.antisym pre_below_one pre_post_one_one pre_pre_one mult_left_isotone)
  thus ?thesis
    by (metis mult_assoc tests_dual.sup_complement mult_left_sub_dist_sup_left mult_left_zero mult_1_right tests_dual.inf_complement test_mult_right_distr_sup order_trans)
qed

lemma pre_post_one_def:
  "1⊣-q = Hd*(-q⊔--q*top)"
proof (rule order.antisym)
  have "1 ≤ (1⊣1)*(-q⊔--q)«1"
    by (metis pre_post_pre one_def mult_1_right tests_dual.inf_complement)
  also have "... ≤ (1⊣1)*(-q⊔--q*top)«-q"
    by (metis sup_right_isotone mult_right_isotone mult_1_right one_def post_pre_left_isotone pre_seq pre_test_promote test_dual_test top_right_mult_increasing)
  finally show "1⊣-q ≤ Hd*(-q⊔--q*top)"
    using Hd_pre_post pre_post_galois tests_dual.sub_bot_def by blast
next
  show "Hd*(-q⊔--q*top) ≤ 1⊣-q"
    by (simp add: pre_post_pre_one pre_post_one_def_1)
qed

lemma pre_post_def:
  "-p⊣-q = -p*Hd*(-q⊔--q*top)"
  by (simp add: pre_post_export mult_assoc pre_post_one_def)

end

end

Theory Pre_Post_Modal

(* Title:      Pre-Post Specifications and Modal Operators
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Pre-Post Specifications and Modal Operators›

theory Pre_Post_Modal

imports Pre_Post Hoare_Modal

begin

class pre_post_spec_whiledo = pre_post_spec_greatest + whiledo
begin

lemma nat_test_pre_post:
  "nat_test t s ⟹ -q ≤ s ⟹ (∀n . x ≤ t n*-p*-q⊣(pSum t n*-q)) ⟹ -p⋆x ≤ -q⊣--p*-q"
  by (smt (verit, ccfv_threshold) nat_test_def nat_test_pre pSum_test_nat pre_post_galois tests_dual.sub_sup_closed)

lemma nat_test_pre_post_2:
  "nat_test t s ⟹ -r ≤ s ⟹ (∀n . x ≤ t n*-p⊣(pSum t n)) ⟹ -p⋆x ≤ -r⊣1"
  by (smt (verit, ccfv_threshold) nat_test_def nat_test_pre_2 one_def pSum_test_nat pre_post_galois tests_dual.sub_sup_closed)

end

class pre_post_spec_hoare = pre_post_spec_whiledo + hoare_calculus_sound
begin

lemma pre_post_while:
  "x ≤ -p*-q⊣-q ⟶ -p⋆x ≤ aL*-q⊣-q"
  by (smt aL_test pre_post_galois sub_mult_closed while_soundness)

text ‹Theorem 43.1›

lemma while_soundness_3:
  "test_seq t ⟹ -q ≤ Sum t ⟹ x ≤ t 0*-p*-q⊣aL*-q ⟹ (∀n>0 . x ≤ t n*-p*-q⊣pSum t n*-q) ⟹ -p⋆x ≤ -q⊣--p*-q"
  by (smt (verit, del_insts) aL_test pSum_test tests_dual.inf_closed pre_post_galois sub_mult_closed test_seq_def while_soundness_1)

text ‹Theorem 43.2›

lemma while_soundness_4:
  "test_seq t ⟹ -r ≤ Sum t ⟹ (∀n . x ≤ t n*-p⊣pSum t n) ⟹ -p⋆x ≤ -r⊣1"
  by (smt one_def pSum_test pre_post_galois sub_mult_closed test_seq_def while_soundness_2)

end

class pre_post_spec_hoare_pc_2 = pre_post_spec_hoare + hoare_calculus_pc_2
begin

text ‹Theorem 43.3›

lemma pre_post_while_pc:
  "x ≤ -p*-q⊣-q ⟶ -p⋆x ≤ -q⊣--p*-q"
  by (metis pre_post_galois sub_mult_closed while_soundness_pc)

end

class pre_post_spec_hoare_pc = pre_post_spec_hoare + hoare_calculus_pc
begin

subclass pre_post_spec_hoare_pc_2 ..

lemma pre_post_one_one_top:
  "1⊣1 = top"
  using order.eq_iff pre_one_one pre_post_one_one by auto

end

class pre_post_spec_H = pre_post_spec_greatest + box_precondition + havoc +
  assumes H_zero_2: "H * bot = bot"
  assumes H_split_2: "x ≤ x * -q * top ⊔ H * --q"
begin

subclass idempotent_left_semiring_H
  apply unfold_locales
  apply (rule H_zero_2)
  by (smt H_split_2 tests_dual.complement_bot mult_assoc mult_left_zero mult_1_right one_def)

lemma pre_post_def_iff:
  "-p * x * --q ≤ Z ⟷ x ≤ Z ⊔ --p * top ⊔ H * -q"
proof (rule iffI)
  assume "-p * x * --q ≤ Z"
  hence "x * --q * top ≤ Z ⊔ --p * top"
    by (smt (verit, ccfv_threshold) Z_left_zero_above_one case_split_left_sup mult_assoc mult_left_isotone mult_right_dist_sup mult_right_isotone top_greatest top_mult_top)
  thus "x ≤ Z ⊔ --p * top ⊔ H * -q"
    by (metis sup_left_isotone order_trans H_split_2 tests_dual.double_negation)
next
  assume "x ≤ Z ⊔ --p * top ⊔ H * -q"
  hence "-p * x * --q ≤ -p * (Z * --q ⊔ --p * top * --q ⊔ H * -q * --q)"
    by (metis mult_left_isotone mult_right_dist_sup mult_right_isotone mult_assoc)
  thus "-p * x * --q ≤ Z"
    by (metis H_zero_2 Z_mult_decreasing sup_commute sup_bot_left mult_assoc mult_right_dist_sup mult_right_isotone order_trans test_mult_left_dist_shunt test_mult_left_sub_dist_shunt tests_dual.top_def)
qed

lemma pre_post_def:
  "-p⊣-q = Z ⊔ --p*top ⊔ H*-q"
  by (meson order.antisym order_refl pre_Z pre_post_galois pre_post_def_iff)

end

class pre_post_L = pre_post_spec_greatest + box_while + left_conway_semiring_L + left_kleene_conway_semiring +
  assumes circ_below_L_add_star: "x⇧^∘ ≤ L ⊔ x⇧^⋆"
begin

text ‹a loop does not abort if its body does not abort›
text ‹this avoids abortion from all states* alternatively from states in -r if -r is an invariant›

lemma body_abort_loop:
  assumes "Z = L"
      and "x ≤ -p⊣1"
    shows "-p⋆x ≤ 1⊣1"
proof -
  have "-p * x * bot ≤ L"
    by (metis assms pre_Z pre_post_galois tests_dual.sba_dual.one_def tests_dual.top_double_complement)
  hence "(-p * x)⇧^⋆ * bot ≤ L"
    by (metis L_split le_iff_sup star_left_induct sup_bot_left)
  hence "(-p * x)⇧^∘ * bot ≤ L"
    by (smt L_left_zero L_split sup_commute circ_below_L_add_star le_iff_sup mult_right_dist_sup)
  thus ?thesis
    by (metis assms(1) a_restrict mult_isotone pre_pc_Z pre_post_compose_2 pre_post_one_one tests_dual.sba_dual.one_def while_def tests_dual.sup_right_zero)
qed

end

class pre_post_spec_Hd = pre_post_spec_least + diamond_precondition + idempotent_left_semiring_Hd +
  assumes d_mult_top: "d(x) * top = x * top"
begin

subclass pre_post_spec_least_Hd
  apply unfold_locales
  by (simp add: d_mult_top diamond_x_1 pre_def)

end

end

Theory Monotonic_Boolean_Transformers

(* Title:      Monotonic Boolean Transformers
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Monotonic Boolean Transformers›

theory Monotonic_Boolean_Transformers

imports MonoBoolTranAlgebra.Assertion_Algebra Base

begin

no_notation inf (infixl "⊓" 70)
no_notation uminus ("- _" [81] 80)

context mbt_algebra
begin

lemma directed_left_mult:
  "directed Y ⟹ directed ((*) x ` Y)"
  apply (unfold directed_def)
  using le_comp by blast

lemma neg_assertion:
  "neg_assert x ∈ assertion"
  by (metis bot_comp neg_assert_def wpt_def wpt_is_assertion mult_assoc)

lemma assertion_neg_assert:
  "x ∈ assertion ⟷ x = neg_assert (neg_assert x)"
  by (metis neg_assertion uminus_uminus)

text ‹extend and dualise part of Viorel Preoteasa's theory›

definition "assumption ≡ {x . 1 ≤ x ∧ (x * bot) ⊔ (x ^ o) = x}"

definition "neg_assume (x::'a) ≡ (x ^ o * top) ⊔ 1"

lemma neg_assume_assert:
  "neg_assume x = (neg_assert (x ^ o)) ^ o"
  using dual_bot dual_comp dual_dual dual_inf dual_one neg_assert_def neg_assume_def by auto

lemma assert_iff_assume:
  "x ∈ assertion ⟷ x ^ o ∈ assumption"
  by (smt assertion_def assumption_def dual_bot dual_comp dual_dual dual_inf dual_le dual_one mem_Collect_eq)

lemma assertion_iff_assumption_subseteq:
  "X ⊆ assertion ⟷ dual ` X ⊆ assumption"
  using assert_iff_assume by blast

lemma assumption_iff_assertion_subseteq:
  "X ⊆ assumption ⟷ dual ` X ⊆ assertion"
  using assert_iff_assume by auto

lemma assumption_prop:
  "x ∈ assumption ⟹ (x * bot) ⊔ 1 = x"
  by (smt assert_iff_assume assertion_prop dual_comp dual_dual dual_neg_top dual_one dual_sup dual_top)

lemma neg_assumption:
  "neg_assume x ∈ assumption"
  using assert_iff_assume neg_assertion neg_assume_assert by auto

lemma assumption_neg_assume:
  "x ∈ assumption ⟷ x = neg_assume (neg_assume x)"
  by (smt assert_iff_assume assertion_neg_assert dual_dual neg_assume_assert)

lemma assumption_sup_comp_eq:
  "x ∈ assumption ⟹ y ∈ assumption ⟹ x ⊔ y = x * y"
  by (smt assert_iff_assume assertion_inf_comp_eq dual_comp dual_dual dual_sup)

lemma sup_uminus_assume[simp]:
  "x ∈ assumption ⟹ x ⊓ neg_assume x = 1"
  by (smt assert_iff_assume dual_dual dual_one dual_sup neg_assume_assert sup_uminus)

lemma inf_uminus_assume[simp]:
  "x ∈ assumption ⟹ x ⊔ neg_assume x = top"
  by (smt assert_iff_assume dual_dual dual_sup dual_top inf_uminus neg_assume_assert sup_bot_right)

lemma uminus_assumption[simp]:
  "x ∈ assumption ⟹ neg_assume x ∈ assumption"
  by (simp add: neg_assumption)

lemma uminus_uminus_assume[simp]:
  "x ∈ assumption ⟹ neg_assume (neg_assume x) = x"
  by (simp add: assumption_neg_assume)

lemma sup_assumption[simp]:
  "x ∈ assumption ⟹ y ∈ assumption ⟹ x ⊔ y ∈ assumption"
  by (smt assert_iff_assume dual_dual dual_sup inf_assertion)

lemma comp_assumption[simp]:
  "x ∈ assumption ⟹ y ∈ assumption ⟹ x * y ∈ assumption"
  using assumption_sup_comp_eq sup_assumption by auto

lemma inf_assumption[simp]:
  "x ∈ assumption ⟹ y ∈ assumption ⟹ x ⊓ y ∈ assumption"
  by (smt assert_iff_assume dual_dual dual_inf sup_assertion)

lemma assumption_comp_idempotent[simp]:
  "x ∈ assumption ⟹ x * x = x"
  using assumption_sup_comp_eq by fastforce

lemma assumption_comp_idempotent_dual[simp]:
  "x ∈ assumption ⟹ (x ^ o) * (x ^ o) = x ^ o"
  by (metis assumption_comp_idempotent dual_comp)

lemma top_assumption[simp]:
  "top ∈ assumption"
  by (simp add: assumption_def)

lemma one_assumption[simp]:
  "1 ∈ assumption"
  by (simp add: assumption_def)

lemma assert_top:
  "neg_assert (neg_assert p) ^ o * bot = neg_assert p * top"
  by (smt bot_comp dual_comp dual_dual dual_top inf_comp inf_top_right mult.assoc mult.left_neutral neg_assert_def)

lemma assume_bot:
  "neg_assume (neg_assume p) ^ o * top = neg_assume p * bot"
  by (smt assert_top dual_bot dual_comp dual_dual neg_assume_assert)

definition "wpb x ≡ (x * bot) ⊔ 1"

lemma wpt_iff_wpb:
  "wpb x = wpt (x ^ o) ^ o"
  using dual_comp dual_dual dual_inf dual_one dual_top wpt_def wpb_def by auto

lemma wpb_is_assumption[simp]:
  "wpb x ∈ assumption"
  using assert_iff_assume wpt_is_assertion wpt_iff_wpb by auto

lemma wpb_comp:
  "(wpb x) * x = x"
  by (smt dual_comp dual_dual dual_neg_top dual_sup wpt_comp wpt_iff_wpb)

lemma wpb_comp_2:
  "wpb (x * y) = wpb (x * (wpb y))"
  by (simp add: sup_comp mult_assoc wpb_def)

lemma wpb_assumption[simp]:
  "x ∈ assumption ⟹ wpb x = x"
  by (simp add: assumption_prop wpb_def)

lemma wpb_choice:
  "wpb (x ⊔ y) = wpb x ⊔ wpb y"
  using sup_assoc sup_commute sup_comp wpb_def by auto

lemma wpb_dual_assumption:
  "x ∈ assumption ⟹ wpb (x ^ o) = 1"
  by (smt assert_iff_assume dual_dual dual_one wpt_dual_assertion wpt_iff_wpb)

lemma wpb_mono:
  "x ≤ y ⟹ wpb x ≤ wpb y"
  by (metis le_iff_sup wpb_choice)

lemma assumption_disjunctive:
  "x ∈ assumption ⟹ x ∈ disjunctive"
  by (smt assert_iff_assume assertion_conjunctive dual_comp dual_conjunctive dual_dual)

lemma assumption_conjunctive:
  "x ∈ assumption ⟹ x ∈ conjunctive"
  by (smt assert_iff_assume assertion_disjunctive dual_comp dual_disjunctive dual_dual)

lemma wpb_le_assumption:
  "x ∈ assumption ⟹ x * y = y ⟹ x ≤ wpb y"
  by (metis assumption_prop bot_least le_comp sup_commute sup_right_isotone mult_assoc wpb_def)

definition dual_omega :: "'a ⇒ 'a" ("(_ ^ ℧)" [81] 80)
  where "(x ^ ℧) ≡ (((x ^ o) ^ ω) ^ o)"

lemma dual_omega_fix:
  "x^℧ = (x * (x^℧)) ⊔ 1"
  by (smt dual_comp dual_dual dual_omega_def dual_one dual_sup omega_fix)

lemma dual_omega_comp_fix:
  "x^℧ * y = (x * (x^℧) * y) ⊔ y"
  by (metis dual_omega_fix mult_1_left sup_comp)

lemma dual_omega_greatest:
  "z ≤ (x * z) ⊔ y ⟹ z ≤ (x^℧) * y"
  by (smt dual_comp dual_dual dual_le dual_neg_top dual_omega_def dual_sup omega_least)

end

context post_mbt_algebra
begin

lemma post_antitone:
  assumes "x ≤ y"
    shows "post y ≤ post x"
proof -
  have "post y ≤ post x * y * top ⊓ post y"
    by (metis assms inf_top_left post_1 inf_mono le_comp_left_right order_refl)
  thus ?thesis
    using order_lesseq_imp post_2 by blast
qed

lemma post_assumption_below_one:
  "q ∈ assumption ⟹ post q ≤ post 1"
  by (simp add: assumption_def post_antitone)

lemma post_assumption_above_one:
  "q ∈ assumption ⟹ post 1 ≤ post (q ^ o)"
  by (metis dual_le dual_one post_antitone sup.commute sup_ge1 wpb_assumption wpb_def)

lemma post_assumption_below_dual:
  "q ∈ assumption ⟹ post q ≤ post (q ^ o)"
  using order_trans post_assumption_above_one post_assumption_below_one by blast

lemma assumption_assertion_absorb:
  "q ∈ assumption ⟹ q * (q ^ o) = q"
  by (smt CollectE assumption_def assumption_prop bot_comp mult.left_neutral mult_assoc sup_comp)

lemma post_dual_below_post_one:
  assumes "q ∈ assumption"
  shows "post (q ^ o) ≤ post 1 * q"
proof -
  have "post (q ^ o) ≤ post 1 * q * (q ^ o) * top ⊓ post (q ^ o)"
    by (metis assms assumption_assertion_absorb gt_one_comp inf_le1 inf_top_left mult_assoc order_refl post_1 sup_uminus_assume top_unique)
  thus ?thesis
    using order_lesseq_imp post_2 by blast
qed

lemma post_below_post_one:
  "q ∈ assumption ⟹ post q ≤ post 1 * q"
  using order.trans post_assumption_below_dual post_dual_below_post_one by blast

end

context complete_mbt_algebra
begin

lemma Inf_assumption[simp]:
  "X ⊆ assumption ⟹ Inf X ∈ assumption"
  by (metis Sup_assertion assert_iff_assume assumption_iff_assertion_subseteq dual_Inf dual_dual)

definition "continuous x ≡ (∀Y . directed Y ⟶ x * (SUP y∈Y . y) = (SUP y∈Y . x * y))"

definition "Continuous ≡ { x . continuous x }"

lemma continuous_Continuous:
  "continuous x ⟷ x ∈ Continuous"
  by (simp add: Continuous_def)

text ‹Theorem 53.1›

lemma one_continuous:
  "1 ∈ Continuous"
  by (simp add: Continuous_def continuous_def image_def)

lemma continuous_dist_ascending_chain:
  assumes "x ∈ Continuous"
      and "ascending_chain f"
    shows "x * (SUP n::nat . f n) = (SUP n::nat . x * f n)"
proof -
  have "directed (range f)"
    by (simp add: assms(2) ascending_chain_directed)
  hence "x * (SUP n::nat . f n) = (SUP y∈range f . x * y)"
    using assms(1) continuous_Continuous continuous_def by auto
  thus ?thesis
    by (simp add: range_composition)
qed

text ‹Theorem 53.1›

lemma assertion_continuous:
  assumes "x ∈ assertion"
    shows "x ∈ Continuous"
proof -
  have 1: "x = (x * top) ⊓ 1"
    using assms assertion_prop by auto
  have "∀Y . directed Y ⟶ x * (SUP y∈Y . y) = (SUP y∈Y . x * y)"
  proof (rule allI, rule impI)
    fix Y
    assume "directed Y" (* assumption not used *)
    have "x * (SUP y∈Y . y) = (x * top) ⊓ (SUP y∈Y . y)"
      using 1 by (smt inf_comp mult.assoc mult.left_neutral top_comp)
    also have "... = (SUP y∈Y . (x * top) ⊓ y)"
      by (simp add: inf_Sup)
    finally show "x * (SUP y∈Y . y) = (SUP y∈Y . x * y)"
      using 1 by (smt inf_comp mult.left_neutral mult.assoc top_comp SUP_cong)
  qed
  thus ?thesis
    by (simp add: continuous_def Continuous_def)
qed

text ‹Theorem 53.1›

lemma assumption_continuous:
  assumes "x ∈ assumption"
    shows "x ∈ Continuous"
proof -
  have 1: "x = (x * bot) ⊔ 1"
    by (simp add: assms assumption_prop)
  have "∀Y . directed Y ⟶ x * (SUP y∈Y . y) = (SUP y∈Y . x * y)"
  proof (rule allI, rule impI)
    fix Y
    assume 2: "directed Y"
    have "x * (SUP y∈Y . y) = (x * bot) ⊔ (SUP y∈Y . y)"
      using 1 by (smt sup_comp mult.assoc mult.left_neutral bot_comp)
    also have "... = (SUP y∈Y . (x * bot) ⊔ y)"
      using 2 by (smt (verit, ccfv_threshold) sup_SUP SUP_cong directed_def)
    finally show "x * (SUP y∈Y . y) = (SUP y∈Y . x * y)"
      using 1 by (metis sup_comp mult.left_neutral mult.assoc bot_comp SUP_cong)
  qed
  thus ?thesis
    by (simp add: continuous_def Continuous_def)
qed

text ‹Theorem 53.1›

lemma mult_continuous:
  assumes "x ∈ Continuous"
      and "y ∈ Continuous"
    shows "x * y ∈ Continuous"
proof -
  have "∀Y. directed Y ⟶ x * y * (SUP y∈Y . y) = (SUP z∈Y . x * y * z)"
  proof (rule allI, rule impI)
    fix Y
    assume "directed Y"
    hence "x * y * (SUP w∈Y . w) = (SUP z∈Y . x * (y * z))"
      by (metis assms continuous_Continuous continuous_def directed_left_mult image_ident image_image mult_assoc)
    thus "x * y * (SUP y∈Y . y) = (SUP z∈Y . x * y * z)"
      using mult_assoc by auto
  qed
  thus ?thesis
    using Continuous_def continuous_def by blast
qed

text ‹Theorem 53.1›

lemma sup_continuous:
  "x ∈ Continuous ⟹ y ∈ Continuous ⟹ x ⊔ y ∈ Continuous"
  by (smt SUP_cong SUP_sup_distrib continuous_Continuous continuous_def sup_comp)

text ‹Theorem 53.1›

lemma inf_continuous:
  assumes "x ∈ Continuous"
      and "y ∈ Continuous"
    shows "x ⊓ y ∈ Continuous"
proof -
  have "∀Y. directed Y ⟶ (x ⊓ y) * (SUP y∈Y . y) = (SUP z∈Y . (x ⊓ y) * z)"
  proof (rule allI, rule impI)
    fix Y
    assume 1: "directed Y"
    have 2: "(SUP w∈Y . SUP z∈Y . (x * w) ⊓ (y * z)) ≤ (SUP z∈Y . (x * z) ⊓ (y * z))"
    proof (intro SUP_least)
      fix w z
      assume "w ∈ Y" and "z ∈ Y"
      from this obtain v where 3: "v∈Y ∧ w ≤ v ∧ z ≤ v"
        using 1 by (meson directed_def)
      hence "x * w ⊓ (y * z) ≤ (x * v) ⊓ (y * v)"
        by (meson inf.sup_mono le_comp)
      thus "x * w ⊓ (y * z) ≤ (SUP z∈Y . (x * z) ⊓ (y * z))"
        using 3 by (meson SUP_upper2)
    qed
    have "(SUP z∈Y . (x * z) ⊓ (y * z)) ≤ (SUP w∈Y . SUP z∈Y . (x * w) ⊓ (y * z))"
      apply (rule SUP_least)
      by (meson SUP_upper SUP_upper2)
    hence "(SUP w∈Y . SUP z∈Y . (x * w) ⊓ (y * z)) = (SUP z∈Y . (x ⊓ y) * z)"
      using 2 order.antisym inf_comp by auto
    thus "(x ⊓ y) * (SUP y∈Y . y) = (SUP z∈Y . (x ⊓ y) * z)"
      using 1 by (metis assms inf_comp continuous_Continuous continuous_def SUP_inf_distrib2)
  qed
  thus ?thesis
    using Continuous_def continuous_def by blast
qed

text ‹Theorem 53.1›

lemma dual_star_continuous:
  assumes "x ∈ Continuous"
    shows "x ^ ⊗ ∈ Continuous"
proof -
  have "∀Y. directed Y ⟶ (x ^ ⊗) * (SUP y∈Y . y) = (SUP z∈Y . (x ^ ⊗) * z)"
  proof (rule allI, rule impI)
    fix Y
    assume "directed Y"
    hence "directed ((*) (x ^ ⊗) ` Y)"
      by (simp add: directed_left_mult)
    hence "x * (SUP y∈Y . (x ^ ⊗) * y) = (SUP y∈Y . x * ((x ^ ⊗) * y))"
      by (metis assms continuous_Continuous continuous_def image_ident image_image)
    also have "... = (SUP y∈Y . x * (x ^ ⊗) * y)"
      using mult_assoc by auto
    also have "... ≤ (SUP y∈Y . (x ^ ⊗) * y)"
      apply (rule SUP_least)
      by (simp add: SUP_upper2 dual_star_comp_fix)
    finally have "x * (SUP y∈Y . (x ^ ⊗) * y) ⊔ (SUP y∈Y . y) ≤ (SUP y∈Y . (x ^ ⊗) * y)"
      apply (rule sup_least)
      by (metis SUP_mono' dual_star_comp_fix sup.cobounded1 sup_commute)
    thus "(x ^ ⊗) * (SUP y∈Y . y) = (SUP z∈Y . (x ^ ⊗) * z)"
      by (meson SUP_least SUP_upper order.antisym dual_star_least le_comp)
  qed
  thus ?thesis
    using Continuous_def continuous_def by blast
qed

text ‹Theorem 53.1›

lemma omega_continuous:
  assumes "x ∈ Continuous"
    shows "x ^ ω ∈ Continuous"
proof -
  have "∀Y. directed Y ⟶ (x ^ ω) * (SUP y∈Y . y) = (SUP z∈Y . (x ^ ω) * z)"
  proof (rule allI, rule impI)
    fix Y
    assume 1: "directed Y"
    hence "directed ((*) (x ^ ω) ` Y)"
      using directed_left_mult by auto
    hence "x * (SUP y∈Y . (x ^ ω) * y) = (SUP y∈Y . x * ((x ^ ω) * y))"
      by (metis assms continuous_Continuous continuous_def image_ident image_image)
    hence 2: "x * (SUP y∈Y . (x ^ ω) * y) = (SUP y∈Y . x * (x ^ ω) * y)"
      by (simp add: mult_assoc)
    have "(SUP y∈Y . x * (x ^ ω) * y) ⊓ (SUP y∈Y . y) = (SUP w∈Y . SUP z∈Y . (x * (x ^ ω) * w) ⊓ z)"
      using SUP_inf_distrib2 by blast
    hence "x * (SUP y∈Y . (x ^ ω) * y) ⊓ (SUP y∈Y . y) = (SUP w∈Y . SUP z∈Y . (x * (x ^ ω) * w) ⊓ z)"
      using 2 by auto
    also have "... ≤ (SUP y∈Y . (x ^ ω) * y)"
    proof (intro SUP_least)
      fix w z
      assume "w ∈ Y" and "z ∈ Y"
      from this obtain v where 3: "v∈Y ∧ w ≤ v ∧ z ≤ v"
        using 1 by (meson directed_def)
      hence "x * x ^ ω * w ⊓ z ≤ x ^ ω * v"
        using inf.sup_mono le_comp omega_comp_fix by auto
      thus "x * x ^ ω * w ⊓ z ≤ (SUP y∈Y . (x ^ ω) * y)"
        using 3 by (meson SUP_upper2)
    qed
    finally show "(x ^ ω) * (SUP y∈Y . y) = (SUP z∈Y . (x ^ ω) * z)"
      by (meson SUP_least SUP_upper order.antisym omega_least le_comp)
  qed
  thus ?thesis
    using Continuous_def continuous_def by blast
qed

definition "co_continuous x ≡ (∀Y . co_directed Y ⟶ x * (INF y∈Y . y) = (INF y∈Y . x * y))"

definition "Co_continuous ≡ { x . co_continuous x }"

lemma directed_dual:
  "directed X ⟷ co_directed (dual ` X)"
  by (simp add: directed_def co_directed_def dual_le[THEN sym])

lemma dual_dual_image:
  "dual ` dual ` X = X"
  by (simp add: image_comp)

lemma continuous_dual:
  "continuous x ⟷ co_continuous (x ^ o)"
proof (unfold continuous_def co_continuous_def, rule iffI)
  assume 1: "∀Y. directed Y ⟶ x * (SUP y∈Y . y) = (SUP y∈Y . x * y)"
  show "∀Y. co_directed Y ⟶ x ^ o * (INF y∈Y . y) = (INF y∈Y . x ^ o * y)"
  proof (rule allI, rule impI)
    fix Y
    assume "co_directed Y"
    hence "x ^ o * (INF y∈Y . y) = (INF y∈(dual ` Y) . (x * y) ^ o)"
      using 1 by (metis dual_dual_image dual_SUP image_ident image_image dual_comp directed_dual)
    also have "... = (INF y∈(dual ` Y) . x ^ o * y ^ o)"
      by (meson dual_comp)
    also have "... = (INF y∈Y . x ^ o * y)"
      by (simp add: image_image)
    finally show "x ^ o * (INF y∈Y . y) = (INF y∈Y . x ^ o * y)"
      .
 qed
next
  assume 2: "∀Y. co_directed Y ⟶ x ^ o * (INF y∈Y . y) = (INF y∈Y . x ^ o * y)"
  show "∀Y. directed Y ⟶ x * (SUP y∈Y . y) = (SUP y∈Y . x * y)"
  proof (rule allI, rule impI)
    fix Y
    assume "directed Y"
    hence "x * (SUP y∈Y . y) = (SUP y∈(dual ` Y) . (x ^ o * y) ^ o)"
      using 2 by (metis directed_dual dual_dual_image image_ident image_image dual_SUP dual_comp dual_dual)
    also have "... = (SUP y∈(dual ` Y) . x * y ^ o)"
      using dual_comp dual_dual by auto
    also have "... = (SUP y∈Y . x * y)"
      by (simp add: image_image)
    finally show "x * (SUP y∈Y . y) = (SUP y∈Y . x * y)"
      .
 qed
qed

lemma co_continuous_Co_continuous:
  "co_continuous x ⟷ x ∈ Co_continuous"
  by (simp add: Co_continuous_def)

text ‹Theorem 53.1 and Theorem 53.2›

lemma Continuous_dual:
  "x ∈ Continuous ⟷ x ^ o ∈ Co_continuous"
  by (simp add: Co_continuous_def Continuous_def continuous_dual)

text ‹Theorem 53.2›

lemma one_co_continuous:
  "1 ∈ Co_continuous"
  using Continuous_dual one_continuous by auto

lemma ascending_chain_dual:
  "ascending_chain f ⟷ descending_chain (dual o f)"
  using ascending_chain_def descending_chain_def dual_le by auto

lemma co_continuous_dist_descending_chain:
  assumes "x ∈ Co_continuous"
      and "descending_chain f"
    shows "x * (INF n::nat . f n) = (INF n::nat . x * f n)"
proof -
  have "x ^ o * (SUP n::nat . (dual o f) n) = (SUP n::nat . x ^ o * (dual o f) n)"
    by (smt assms Continuous_dual SUP_cong ascending_chain_dual continuous_dist_ascending_chain descending_chain_def dual_dual o_def)
  thus ?thesis
    by (smt INF_cong dual_SUP dual_comp dual_dual o_def)
qed

text ‹Theorem 53.2›

lemma assertion_co_continuous:
  "x ∈ assertion ⟹ x ∈ Co_continuous"
  by (smt Continuous_dual assert_iff_assume assumption_continuous dual_dual)

text ‹Theorem 53.2›

lemma assumption_co_continuous:
  "x ∈ assumption ⟹ x ∈ Co_continuous"
  by (smt Continuous_dual assert_iff_assume assertion_continuous dual_dual)

text ‹Theorem 53.2›

lemma mult_co_continuous:
  "x ∈ Co_continuous ⟹ y ∈ Co_continuous ⟹ x * y ∈ Co_continuous"
  by (smt Continuous_dual dual_comp dual_dual mult_continuous)

text ‹Theorem 53.2›

lemma sup_co_continuous:
  "x ∈ Co_continuous ⟹ y ∈ Co_continuous ⟹ x ⊔ y ∈ Co_continuous"
  by (smt Continuous_dual dual_sup dual_dual inf_continuous)

text ‹Theorem 53.2›

lemma inf_co_continuous:
  "x ∈ Co_continuous ⟹ y ∈ Co_continuous ⟹ x ⊓ y ∈ Co_continuous"
  by (smt Continuous_dual dual_inf dual_dual sup_continuous)

text ‹Theorem 53.2›

lemma dual_omega_co_continuous:
  "x ∈ Co_continuous ⟹ x ^ ℧ ∈ Co_continuous"
  by (smt Continuous_dual dual_omega_def dual_dual omega_continuous)

text ‹Theorem 53.2›

lemma star_co_continuous:
  "x ∈ Co_continuous ⟹ x ^ * ∈ Co_continuous"
  by (smt Continuous_dual dual_star_def dual_dual dual_star_continuous)

lemma dual_omega_iterate:
  assumes "y ∈ Co_continuous"
    shows "y ^ ℧ * z = (INF n::nat . ((λx . y * x ⊔ z) ^ n) top)"
proof (rule order.antisym)
  show "y ^ ℧ * z ≤ (INF n::nat . ((λx . y * x ⊔ z) ^ n) top)"
  proof (rule INF_greatest)
    fix n
    show "y ^ ℧ * z ≤ ((λx. y * x ⊔ z) ^ n) top"
      apply (induct n)
      apply (metis power_zero_id id_def top_greatest)
      by (smt dual_omega_comp_fix le_comp mult_assoc order_refl sup_mono power_succ_unfold_ext)
  qed
next
  have 1: "descending_chain (λn . ((λx. y * x ⊔ z) ^ n) top)"
  proof (unfold descending_chain_def, rule allI)
    fix n
    show "((λx. y * x ⊔ z) ^ Suc n) top ≤ ((λx. y * x ⊔ z) ^ n) top"
      apply (induct n)
      apply (metis power_zero_id id_def top_greatest)
      by (smt power_succ_unfold_ext sup_mono order_refl le_comp)
  qed
  have "(INF n. ((λx. y * x ⊔ z) ^ n) top) ≤ (INF n. ((λx. y * x ⊔ z) ^ Suc n) top)"
    apply (rule INF_greatest)
    apply (unfold power_succ_unfold_ext)
    by (smt power_succ_unfold_ext INF_lower UNIV_I)
  thus "(INF n. ((λx. y * x ⊔ z) ^ n) top) ≤ y ^ ℧ * z"
    using 1 by (smt assms INF_cong co_continuous_dist_descending_chain power_succ_unfold_ext sup_INF sup_commute dual_omega_greatest)
qed

lemma dual_omega_iterate_one:
  "y ∈ Co_continuous ⟹ y ^ ℧ = (INF n::nat . ((λx . y * x ⊔ 1) ^ n) top)"
  by (metis dual_omega_iterate mult.right_neutral)

subclass ccpo
  apply unfold_locales
  apply (simp add: Sup_upper)
  using Sup_least by auto

end

class post_mbt_algebra_ext = post_mbt_algebra +
  assumes post_sub_fusion: "post 1 * neg_assume q ≤ post (neg_assume q ^ o)"
begin

lemma post_fusion:
  "post (neg_assume q ^ o) = post 1 * neg_assume q"
  using order.antisym neg_assumption post_dual_below_post_one post_sub_fusion by auto

lemma post_dual_post_one:
  "q ∈ assumption ⟹ post 1 * q ≤ post (q ^ o)"
  by (metis assumption_neg_assume post_sub_fusion)

end

instance MonoTran :: (complete_boolean_algebra) post_mbt_algebra_ext
proof
  fix q :: "'a MonoTran"
  show "post 1 * neg_assume q ≤ post (neg_assume q ^ o)"
  proof (unfold neg_assume_def, transfer)
    fix f :: "'a ⇒ 'a"
    assume "mono f"
    have "∀x. top ≤ -f bot ⊔ x ⟶ ¬ f bot ≤ x ⟶ top ≤ bot"
      by (metis (no_types, lifting) double_compl inf.sup_bot_left inf_compl_bot sup.order_iff sup_bot_left sup_commute sup_inf_distrib1 top.extremum_uniqueI)
    hence "post_fun top ∘ (dual_fun f ∘ top) ⊔ id ≤ post_fun (f bot)"
      by (simp add: dual_fun_def le_fun_def post_fun_def)
    thus "post_fun (id top) ∘ (dual_fun f ∘ top) ⊔ id ≤ post_fun (dual_fun ((dual_fun f ∘ top) ⊔ id) top)"
      by simp
  qed
qed

class complete_mbt_algebra_ext = complete_mbt_algebra + post_mbt_algebra_ext

instance MonoTran :: (complete_boolean_algebra) complete_mbt_algebra_ext ..

end

Theory Monotonic_Boolean_Transformers_Instances

(* Title:      Instances of Monotonic Boolean Transformers
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Instances of Monotonic Boolean Transformers›

theory Monotonic_Boolean_Transformers_Instances

imports Monotonic_Boolean_Transformers Pre_Post_Modal General_Refinement_Algebras

begin

sublocale mbt_algebra < mbta: bounded_idempotent_left_semiring
  apply unfold_locales
  apply (simp add: le_comp)
  apply (simp add: sup_comp)
  apply simp
  apply simp
  apply simp
  apply simp
  by (simp add: mult_assoc)

sublocale mbt_algebra < mbta_dual: bounded_idempotent_left_semiring where less = greater and less_eq = greater_eq and sup = inf and bot = top and top = bot
  apply unfold_locales
  using inf.bounded_iff inf_le1 inf_le2 mbta.mult_right_isotone apply simp
  using inf_comp apply blast
  apply simp
  apply simp
  apply simp
  apply simp
  by (simp add: mult_assoc)

sublocale mbt_algebra < mbta: bounded_general_refinement_algebra where star = dual_star and Omega = dual_omega
  apply unfold_locales
  using dual_star_fix sup_commute apply force
  apply (simp add: dual_star_least)
  using dual_omega_fix sup_commute apply force
  by (simp add: dual_omega_greatest sup_commute)

sublocale mbt_algebra < mbta_dual: bounded_general_refinement_algebra where less = greater and less_eq = greater_eq and sup = inf and bot = top and Omega = omega and top = bot
  apply unfold_locales
  using order.eq_iff star_fix apply simp
  using star_greatest apply simp
  using inf_commute omega_fix apply fastforce
  by (simp add: inf.sup_monoid.add_commute omega_least)

text ‹Theorem 50.9(b)›

sublocale mbt_algebra < mbta: left_conway_semiring_L where circ = dual_star and L = bot
  apply unfold_locales
  apply (simp add: mbta.star_one)
  by simp

text ‹Theorem 50.8(a)›

sublocale mbt_algebra < mbta_dual: left_conway_semiring_L where circ = omega and less = greater and less_eq = greater_eq and sup = inf and bot = top and L = bot
  apply unfold_locales
  apply simp
  by simp

text ‹Theorem 50.8(b)›

sublocale mbt_algebra < mbta_fix: left_conway_semiring_L where circ = dual_omega and L = top
  apply unfold_locales
  apply (simp add: mbta.Omega_one)
  by simp

text ‹Theorem 50.9(a)›

sublocale mbt_algebra < mbta_fix_dual: left_conway_semiring_L where circ = star and less = greater and less_eq = greater_eq and sup = inf and bot = top and L = top
  apply unfold_locales
  apply (simp add: mbta_dual.star_one)
  by simp

sublocale mbt_algebra < mbta: left_kleene_conway_semiring where circ = dual_star and star = dual_star ..

sublocale mbt_algebra < mbta_dual: left_kleene_conway_semiring where circ = omega and less = greater and less_eq = greater_eq and sup = inf and bot = top ..

sublocale mbt_algebra < mbta_fix: left_kleene_conway_semiring where circ = dual_omega and star = dual_star ..

sublocale mbt_algebra < mbta_fix_dual: left_kleene_conway_semiring where circ = star and less = greater and less_eq = greater_eq and sup = inf and bot = top ..

sublocale mbt_algebra < mbta: tests where uminus = neg_assert
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (metis neg_assertion assertion_inf_comp_eq inf_commute)
  subgoal for x y
  proof -
    have "(x ^ o * bot ⊔ y * top) ⊓ ((x ^ o * bot ⊔ y ^ o * bot) ⊓ 1) = x ^ o * bot ⊓ 1"
      by (metis inf_assoc dual_neg sup_bot_right sup_inf_distrib1)
    thus ?thesis
      by (simp add: dual_inf dual_comp inf_comp sup_comp neg_assert_def)
  qed
  apply (simp add: neg_assertion)
  using assertion_inf_comp_eq inf_uminus neg_assertion apply force
  apply (simp add: neg_assert_def)
  apply (simp add: dual_inf dual_comp sup_comp neg_assert_def inf_sup_distrib2)
  apply (simp add: assertion_inf_comp_eq inf.absorb_iff1 neg_assertion)
  using inf.less_le_not_le by blast

sublocale mbt_algebra < mbta_dual: tests where less = greater and less_eq = greater_eq and sup = inf and uminus = neg_assume and bot = top
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (metis neg_assumption assumption_sup_comp_eq sup_commute)
  subgoal for x y
  proof -
    have "(x ^ o * top ⊓ y * bot) ⊔ ((x ^ o * top ⊓ y ^ o * top) ⊔ 1) = x ^ o * top ⊔ 1"
      by (metis dual_dual dual_neg_top inf_sup_distrib1 inf_top_right sup_assoc)
    thus ?thesis
      by (simp add: dual_comp dual_sup inf_comp sup_comp neg_assume_def)
  qed
  using assumption_neg_assume comp_assumption neg_assumption apply blast
  using assumption_sup_comp_eq inf_uminus_assume neg_assumption apply fastforce
  apply (simp add: neg_assume_def)
  apply (simp add: dual_inf dual_comp dual_sup inf_comp sup_comp neg_assume_def sup_inf_distrib2)
  apply (simp add: assumption_sup_comp_eq neg_assumption sup.absorb_iff1)
  using inf.less_le_not_le by auto

text ‹Theorem 51.2›

sublocale mbt_algebra < mbta: bounded_relative_antidomain_semiring where d = "λx . (x * top) ⊓ 1" and uminus = neg_assert and Z = bot
  apply unfold_locales
  subgoal for x
  proof -
    have "x ^ o * bot ⊓ x ≤ bot"
      by (metis dual_neg eq_refl inf.commute inf_mono mbta.top_right_mult_increasing)
    thus ?thesis
      by (simp add: neg_assert_def inf_comp)
  qed
  apply (simp add: dual_comp dual_inf neg_assert_def sup_comp mult_assoc)
  apply simp
  apply simp
  apply (simp add: dual_inf dual_comp sup_comp neg_assert_def inf_sup_distrib2)
  apply (simp add: dual_sup inf_comp neg_assert_def inf.assoc)
  by (simp add: dual_inf dual_comp sup_comp neg_assert_def)

text ‹Theorem 51.1›

sublocale mbt_algebra < mbta_dual: bounded_relative_antidomain_semiring where d = "λx . (x * bot) ⊔ 1" and less = greater and less_eq = greater_eq and sup = inf and uminus = neg_assume and bot = top and top = bot and Z = top
  apply unfold_locales
  subgoal for x
  proof -
    have "top ≤ x ^ o * top ⊔ x"
      by (metis dual_dual dual_neg_top mbta_dual.top_right_mult_increasing sup_commute sup_left_isotone)
    thus ?thesis
      by (simp add: sup_comp neg_assume_def)
  qed
  using assume_bot dual_comp neg_assume_def sup_comp mult_assoc apply simp
  apply simp
  apply simp
  apply (simp add: dual_inf dual_comp dual_sup inf_comp sup_comp neg_assume_def sup_inf_distrib2)
  apply (simp add: dual_inf sup_comp neg_assume_def sup.assoc)
  by (simp add: dual_comp dual_sup inf_comp neg_assume_def)

sublocale mbt_algebra < mbta: relative_domain_semiring_split where d = "λx . (x * top) ⊓ 1" and Z = bot
  apply unfold_locales
  by simp

sublocale mbt_algebra < mbta_dual: relative_domain_semiring_split where d = "λx . (x * bot) ⊔ 1" and less = greater and less_eq = greater_eq and sup = inf and bot = top and Z = top
  apply unfold_locales
  by simp

sublocale mbt_algebra < mbta: diamond_while where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ⊗) * neg_assert p" and Z = bot
  apply unfold_locales
  apply simp
  apply simp
  apply (rule wpt_def)
  apply simp
  by simp

sublocale mbt_algebra < mbta_dual: box_while where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and top = bot and Z = top
  apply unfold_locales
  apply simp
  apply simp
  apply (metis assume_bot dual_comp mbta_dual.a_mult_d_2 mbta_dual.d_def neg_assume_def wpb_def mult_assoc)
  apply simp
  by simp

sublocale mbt_algebra < mbta_fix: diamond_while where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ℧) * neg_assert p" and Z = bot
  apply unfold_locales
  by simp_all

sublocale mbt_algebra < mbta_fix_dual: box_while where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and top = bot and Z = top
  apply unfold_locales
  by simp_all

sublocale mbt_algebra < mbta_pre: box_while where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ⊗) * neg_assert p" and Z = bot
  apply unfold_locales
  apply (metis dual_comp dual_dual dual_top inf_top_right mbta_dual.mult_right_dist_sup mult_1_left neg_assert_def top_comp wpt_def mult_assoc)
  apply simp
  by simp

sublocale mbt_algebra < mbta_pre_dual: diamond_while where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and top = bot and Z = top
  apply unfold_locales
  apply (simp add: wpb_def)
  apply simp
  by simp

sublocale mbt_algebra < mbta_pre_fix: box_while where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ℧) * neg_assert p" and Z = bot
  apply unfold_locales
  by simp_all

sublocale mbt_algebra < mbta_pre_fix_dual: diamond_while where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and top = bot and Z = top
  apply unfold_locales
  by simp_all

sublocale post_mbt_algebra < mbta: pre_post_spec_Hd where box = "λx y . neg_assert (x * neg_assert y)" and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and pre = "λx y . wpt (x * y)" and pre_post = "λp q . p * post q" and uminus = neg_assert and Hd = "post 1" and Z = bot
  apply unfold_locales
  apply (metis mult.assoc mult.left_neutral post_1)
  apply (metis inf.commute inf_top_right mult.assoc mult.left_neutral post_2)
  apply (metis neg_assertion assertion_disjunctive disjunctiveD)
  subgoal for p x q
  proof
    let ?pt = "neg_assert p"
    let ?qt = "neg_assert q"
    assume "?pt ≤ wpt (x * ?qt)"
    hence "?pt * post ?qt ≤ x * ?qt * top * post ?qt ⊓ post ?qt"
      by (metis mbta.mult_left_isotone wpt_def inf_comp mult.left_neutral)
    thus "?pt * post ?qt ≤ x"
      by (smt mbta.top_left_zero mult.assoc post_2 order_trans)
  next
    let ?pt = "neg_assert p"
    let ?qt = "neg_assert q"
    assume "?pt * post ?qt ≤ x"
    thus "?pt ≤ wpt (x * ?qt)"
      by (smt mbta.a_d_closed post_1 mult_assoc mbta.diamond_left_isotone wpt_def)
  qed
  by (simp add: mbta_dual.mult_right_dist_sup)

sublocale post_mbt_algebra < mbta_dual: pre_post_spec_H where box = "λx y . neg_assume (x * neg_assume y)" and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and bot = top and H = "post 1" and top = bot and Z = top
proof
  fix p x q
  let ?pt = "neg_assume p"
  let ?qt = "neg_assume q"
  show "wpb (x ^ o * ?qt) ≤ ?pt ⟷ ?pt ^ o * post (?qt ^ o) ≤ x"
  proof
    assume "wpb (x ^ o * ?qt) ≤ ?pt"
    hence "?pt ^ o * post (?qt ^ o) ≤ (x * (?qt ^ o) * top ⊓ 1) * post (?qt ^ o)"
      by (smt wpb_def dual_le dual_comp dual_dual dual_one dual_sup dual_top mbta.mult_left_isotone)
    thus "?pt ^ o * post (?qt ^ o) ≤ x"
      by (smt inf_comp mult_assoc top_comp mult.left_neutral post_2 order_trans)
  next
    assume 1: "?pt ^ o * post (?qt ^ o) ≤ x"
    have "?pt ^ o = ?pt ^ o * post (?qt ^ o) * (?qt ^ o) * top ⊓ 1"
      by (metis assert_iff_assume assertion_prop dual_dual mult_assoc neg_assumption post_1)
    thus "wpb (x ^ o * ?qt) ≤ ?pt"
      using 1 by (smt dual_comp dual_dual dual_le dual_one dual_sup dual_top wpb_def mbta.diamond_left_isotone)
  qed
  show "post 1 * top = top"
    by (simp add: mbta.Hd_total)
  have "x * ?qt * bot ⊓ (post 1 * neg_assume ?qt) = (x * neg_assume ?qt ^ o * top ⊓ post 1) * neg_assume ?qt"
    by (simp add: assume_bot mbta_dual.mult_right_dist_sup mult_assoc)
  also have "... ≤ x * neg_assume ?qt ^ o"
    by (smt assumption_assertion_absorb dual_comp dual_dual mbta.mult_left_isotone mult.right_neutral mult_assoc neg_assumption post_2)
  also have "... ≤ x"
    by (metis dual_comp dual_dual dual_le mbta.mult_left_sub_dist_sup_left mult.right_neutral neg_assume_def sup.commute)
  finally show "x * ?qt * bot ⊓ (post 1 * neg_assume ?qt) ≤ x"
    .
qed

sublocale post_mbt_algebra < mbta_pre: pre_post_spec_H where box = "λx y . neg_assert (x * neg_assert y)" and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and uminus = neg_assert and H = "post 1 ^ o" and Z = bot
proof
  fix p x q
  let ?pt = "neg_assert p"
  let ?qt = "neg_assert q"
  show "?pt ≤ wpt (x ^ o * ?qt) ⟷ x ≤ ?pt ^ o * (post ?qt ^ o)"
  proof
    assume "?pt ≤ wpt (x ^ o * ?qt)"
    hence "?pt * post ?qt ≤ (x ^ o * ?qt * top ⊓ 1) * post ?qt"
      by (simp add: mbta_dual.mult_left_isotone wpt_def)
    also have "... ≤ x ^ o"
      using mbta.pre_pre_post wpt_def by auto
    finally show "x ≤ ?pt ^ o * (post ?qt ^ o)"
      by (metis dual_le dual_comp dual_dual)
  next
    assume "x ≤ ?pt ^ o * (post ?qt ^ o)"
    hence "x * ?qt ^ o * bot ⊔ 1 ≤ (?pt * post ?qt * ?qt * top ⊓ 1) ^ o"
      by (smt (z3) inf.absorb_iff1 sup_inf_distrib2 dual_comp dual_inf dual_one dual_top mbta.mult_left_isotone)
    also have "... = ?pt ^ o"
      by (simp add: mbta.diamond_a_export post_1)
    finally show "?pt ≤ wpt (x ^ o * ?qt)"
      by (smt dual_comp dual_dual dual_le dual_neg_top dual_one dual_sup dual_top wpt_def)
  qed
  show "post 1 ^ o * bot = bot"
    by (metis dual_comp dual_top mbta.Hd_total)
  have "x ^ o * ?qt ^ o * bot ⊓ (post 1 * neg_assert ?qt ^ o) ≤ x ^ o * neg_assert ?qt * neg_assert ?qt ^ o"
    by (smt (verit, del_insts) bot_comp inf.commute inf_comp inf_top_left mbta.mult_left_isotone mult.left_neutral mult_assoc neg_assert_def post_2)
  also have "... ≤ x ^ o"
    by (smt assert_iff_assume assumption_assertion_absorb dual_comp dual_dual le_comp mbta.a_below_one mult_assoc neg_assertion mult_1_right)
  finally show "x ≤ x * ?qt * top ⊔ post 1 ^ o * neg_assert ?qt"
    by (smt dual_comp dual_dual dual_inf dual_le dual_top)
qed

sublocale post_mbt_algebra < mbta_pre_dual: pre_post_spec_Hd where box = "λx y . neg_assume (x * neg_assume y)" and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and pre_post = "λp q . p * (post (q ^ o) ^ o)" and uminus = neg_assume and bot = top and Hd = "post 1 ^ o" and top = bot and Z = top
  apply unfold_locales
  apply (simp add: mbta_pre.H_zero_2)
  apply (simp add: mbta_pre.H_greatest_finite)
  apply (metis (no_types, lifting) dual_comp dual_dual dual_inf dual_top mbta_dual.mult_L_circ_mult mult_1_right neg_assume_def sup_commute sup_inf_distrib2)
  subgoal for p x q
  proof
    let ?pt = "neg_assume p"
    let ?qt = "neg_assume q"
    assume "wpb (x * ?qt) ≤ ?pt"
    hence "?pt ^ o * post (?qt ^ o) ≤ (x ^ o * ?qt ^ o * top ⊓ 1) * post (?qt ^ o)"
      by (smt dual_comp dual_dual dual_le dual_one dual_sup dual_top le_comp_right wpb_def)
    also have "... ≤ x ^ o"
      using mbta_dual.mult_right_dist_sup post_2 by force
    finally show "x ≤ ?pt * post (?qt ^ o) ^ o"
      by (smt dual_comp dual_dual dual_le)
  next
    let ?pt = "neg_assume p"
    let ?qt = "neg_assume q"
    assume "x ≤ ?pt * post (?qt ^ o) ^ o"
    thus "wpb (x * ?qt) ≤ ?pt"
      by (metis dual_comp dual_dual dual_le mbta_dual.pre_post_galois)
  qed
  by (simp add: sup_comp)

sublocale post_mbt_algebra < mbta_dual: pre_post_spec_whiledo where ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and top = bot ..

sublocale post_mbt_algebra < mbta_fix_dual: pre_post_spec_whiledo where ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and top = bot ..

sublocale post_mbt_algebra < mbta_pre: pre_post_spec_whiledo where ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ⊗) * neg_assert p" ..

sublocale post_mbt_algebra < mbta_pre_fix: pre_post_spec_whiledo where ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ℧) * neg_assert p" ..

sublocale post_mbt_algebra < mbta_dual: pre_post_L where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and L = bot and top = bot and Z = top
  apply unfold_locales
  by simp

sublocale post_mbt_algebra < mbta_fix_dual: pre_post_L where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and L = top and top = bot and Z = top
  apply unfold_locales
  by simp

sublocale post_mbt_algebra < mbta_pre: pre_post_L where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ⊗) * neg_assert p" and L = bot and Z = bot
  apply unfold_locales
  by simp

sublocale post_mbt_algebra < mbta_pre_fix: pre_post_L where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ℧) * neg_assert p" and L = top and Z = bot
  apply unfold_locales
  by simp

sublocale complete_mbt_algebra < mbta: complete_tests where uminus = neg_assert
  apply unfold_locales
  apply (smt mbta.test_set_def neg_assertion subset_eq Sup_assertion assertion_neg_assert)
  apply (simp add: Sup_upper)
  by (simp add: Sup_least)

sublocale complete_mbt_algebra < mbta_dual: complete_tests where less = greater and less_eq = greater_eq and sup = inf and uminus = neg_assume and bot = top and Inf = Sup and Sup = Inf
  apply unfold_locales
  apply (smt mbta_dual.test_set_def neg_assumption subset_eq Inf_assumption assumption_neg_assume)
  apply (simp add: Inf_lower)
  by (simp add: Inf_greatest)

sublocale complete_mbt_algebra < mbta: complete_antidomain_semiring where d = "λx . (x * top) ⊓ 1" and uminus = neg_assert and Z = bot
proof
  fix f :: "nat ⇒ 'a"
  let ?F = "dual ` {f n | n . True}"
  show "ascending_chain f ⟶ neg_assert (complete_tests.Sum Sup f) = complete_tests.Prod Inf (λn. neg_assert (f n))"
  proof
    have "neg_assert (complete_tests.Sum Sup f) = 1 ⊓ (⨅x∈?F . x * bot)"
      using Inf_comp dual_Sup mbta.Sum_def neg_assert_def inf_commute by auto
    also have "... = (⨅x∈?F . 1 ⊓ x * bot)"
      apply (subst inf_Inf)
      apply blast
      by (simp add: image_image)
    also have "... = ⨅{f n ^ o * bot ⊓ 1 | n . True}"
      apply (rule arg_cong[where f="Inf"])
      using inf_commute by auto
    also have "... = complete_tests.Prod Inf (λn. neg_assert (f n))"
      using mbta.Prod_def neg_assert_def by auto
    finally show "neg_assert (complete_tests.Sum Sup f) = complete_tests.Prod Inf (λn. neg_assert (f n))"
      .
  qed
  show "descending_chain f ⟶ neg_assert (complete_tests.Prod Inf f) = complete_tests.Sum Sup (λn. neg_assert (f n))"
  proof
    have "neg_assert (complete_tests.Prod Inf f) = 1 ⊓ (⨆x∈?F . x * bot)"
      using Sup_comp dual_Inf mbta.Prod_def neg_assert_def inf_commute by auto
    also have "... = (⨆x∈?F . 1 ⊓ x * bot)"
      by (simp add: inf_Sup image_image)
    also have "... = ⨆{f n ^ o * bot ⊓ 1 |n. True}"
      apply (rule arg_cong[where f="Sup"])
      using inf_commute by auto
    also have "... = complete_tests.Sum Sup (λn. neg_assert (f n))"
      using mbta.Sum_def neg_assert_def by auto
    finally show "neg_assert (complete_tests.Prod Inf f) = complete_tests.Sum Sup (λn. neg_assert (f n))"
      .
  qed
qed

sublocale complete_mbt_algebra < mbta_dual: complete_antidomain_semiring where d = "λx . (x * bot) ⊔ 1" and less = greater and less_eq = greater_eq and sup = inf and uminus = neg_assume and bot = top and Inf = Sup and Sup = Inf and Z = top
proof
  fix f :: "nat ⇒ 'a"
  let ?F = "dual ` {f n | n . True}"
  show "ord.ascending_chain greater_eq f ⟶ neg_assume (complete_tests.Sum Inf f) = complete_tests.Prod Sup (λn. neg_assume (f n))"
  proof
    have "neg_assume (complete_tests.Sum Inf f) = 1 ⊔ (⨆x∈?F . x * top)"
      using mbta_dual.Sum_def neg_assume_def dual_Inf Sup_comp sup_commute by auto
    also have "... = (⨆x∈?F . 1 ⊔ x * top)"
      apply (subst sup_Sup)
      apply blast
      by (simp add: image_image)
    also have "... = ⨆{f n ^ o * top ⊔ 1 | n . True}"
      apply (rule arg_cong[where f="Sup"])
      using sup_commute by auto
    also have "... = complete_tests.Prod Sup (λn. neg_assume (f n))"
      using mbta_dual.Prod_def neg_assume_def by auto
    finally show "neg_assume (complete_tests.Sum Inf f) = complete_tests.Prod Sup (λn. neg_assume (f n))"
      .
  qed
  show "ord.descending_chain greater_eq f ⟶ neg_assume (complete_tests.Prod Sup f) = complete_tests.Sum Inf (λn. neg_assume (f n))"
  proof
    have "neg_assume (complete_tests.Prod Sup f) = 1 ⊔ (⨅x∈?F . x * top)"
      using mbta_dual.Prod_def neg_assume_def dual_Inf dual_Sup Inf_comp sup_commute by auto
    also have "... = (⨅x∈?F . 1 ⊔ x * top)"
      by (simp add: sup_Inf image_image)
    also have "... = ⨅{f n ^ o * top ⊔ 1 |n. True}"
      apply (rule arg_cong[where f="Inf"])
      using sup_commute by auto
    also have "... = complete_tests.Sum Inf (λn. neg_assume (f n))"
      using mbta_dual.Sum_def neg_assume_def by auto
    finally show "neg_assume (complete_tests.Prod Sup f) = complete_tests.Sum Inf (λn. neg_assume (f n))"
      .
  qed
qed

sublocale complete_mbt_algebra < mbta: diamond_while_program where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ⊗) * neg_assert p" and Atomic_program = Continuous and Atomic_test = assertion and Z = bot
  apply unfold_locales
  apply (simp add: one_continuous)
  by simp_all

sublocale complete_mbt_algebra < mbta_dual: box_while_program where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and Atomic_program = Continuous and Atomic_test = assumption and top = bot and Z = top
  apply unfold_locales
  apply (simp add: one_continuous)
  by simp_all

sublocale complete_mbt_algebra < mbta_fix: diamond_while_program where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ℧) * neg_assert p" and Atomic_program = Co_continuous and Atomic_test = assertion and Z = bot
  apply unfold_locales
  apply (simp add: one_co_continuous)
  by simp_all

sublocale complete_mbt_algebra < mbta_fix_dual: box_while_program where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and Atomic_program = Co_continuous and Atomic_test = assumption and top = bot and Z = top
  apply unfold_locales
  apply (simp add: one_co_continuous)
  by simp_all

sublocale complete_mbt_algebra < mbta_pre: box_while_program where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ⊗) * neg_assert p" and Atomic_program = Continuous and Atomic_test = assertion and Z = bot ..

sublocale complete_mbt_algebra < mbta_pre_dual: diamond_while_program where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and Atomic_program = Continuous and Atomic_test = assumption and top = bot and Z = top ..

sublocale complete_mbt_algebra < mbta_pre_fix: box_while_program where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ℧) * neg_assert p" and Atomic_program = Co_continuous and Atomic_test = assertion and Z = bot ..

sublocale complete_mbt_algebra < mbta_pre_fix_dual: diamond_while_program where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and Atomic_program = Co_continuous and Atomic_test = assumption and top = bot and Z = top ..

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta: diamond_hoare_sound where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ⊗) * neg_assert p" and Atomic_program = Continuous and Atomic_test = assertion and Z = bot
  apply unfold_locales
  by (simp add: mbta.aL_one_circ mbta.star_one)

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_dual: box_hoare_sound where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and Atomic_program = Continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot and Z = top
  apply unfold_locales
  using mbta.top_greatest mbta.vector_bot_closed mbta_dual.aL_one_circ mbta_dual.a_top omega_one top_comp by auto

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_fix: diamond_hoare_sound_2 where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ℧) * neg_assert p" and Atomic_program = Co_continuous and Atomic_test = assertion and Z = bot
proof (unfold_locales, rule impI)
  fix p q x
  let ?pt = "neg_assert p"
  let ?qt = "neg_assert q"
  assume "neg_assert ?pt * ?qt ≤ x * ?qt * top ⊓ 1"
  hence "?qt * top ≤ x ^ ℧ * ?pt * top"
    by (smt mbta.Omega_induct mbta.d_def mbta.d_mult_top mbta.mult_left_isotone mbta.shunting_top_1 mult.assoc)
  thus "mbta_fix.aL * ?qt ≤ x ^ ℧ * ?pt * top ⊓ 1"
    by (smt (z3) inf.absorb_iff1 inf.sup_monoid.add_commute inf_comp inf_le2 inf_left_commute inf_top_left mbta_fix.aL_one_circ mbta_pre_dual.top_left_zero mult_1_left neg_assert_def mult.assoc)
qed

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_fix_dual: box_hoare_sound where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and Atomic_program = Co_continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot and Z = top
  apply unfold_locales
  by (simp add: mbta_dual.star_one mbta_fix_dual.aL_one_circ)

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_pre: box_hoare_sound where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ⊗) * neg_assert p" and Atomic_program = Continuous and Atomic_test = assertion and Z = bot
  apply unfold_locales
  using mbta.star_one mbta_pre.aL_one_circ by auto

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_pre_dual: diamond_hoare_sound_2 where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and Atomic_program = Continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot and Z = top
proof (unfold_locales, rule impI)
  fix p q x
  let ?pt = "neg_assume p"
  let ?qt = "neg_assume q"
  assume "x * ?qt * bot ⊔ 1 ≤ neg_assume ?pt * ?qt"
  hence "x * ?qt * bot ⊓ ?pt ≤ ?qt"
    by (smt (z3) inf.absorb_iff1 inf_left_commute inf_commute inf_le1 le_supE mbta_dual.a_compl_intro mbta_dual.d_def order_trans)
  hence "(x * ?qt * bot ⊓ ?pt) * bot ≤ ?qt * bot"
    using mbta.mult_left_isotone by blast
  hence "x ^ ω * ?pt * bot ⊔ 1 ≤ ?qt"
    by (smt bot_comp inf_comp sup_left_isotone mbta_dual.a_d_closed mult_assoc omega_least)
  thus "x ^ ω * ?pt * bot ⊔ 1 ≤ mbta_pre_dual.aL * ?qt"
    by (simp add: mbta_pre_dual.aL_one_circ)
qed

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_pre_fix: box_hoare_sound where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ℧) * neg_assert p" and Atomic_program = Co_continuous and Atomic_test = assertion and Z = bot
  apply unfold_locales
  using mbta.Omega_one mbta_pre_fix.aL_def by auto

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_pre_fix_dual: diamond_hoare_sound where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and Atomic_program = Co_continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot and Z = top
  apply unfold_locales
  by (simp add: mbta_dual.star_one mbta_pre_fix_dual.aL_one_circ)

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta: diamond_hoare_valid where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and hoare_triple = "λp x q . p ≤ wpt(x * q)" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ⊗) * neg_assert p" and Atomic_program = Continuous and Atomic_test = assertion and Z = bot
  apply unfold_locales
  apply (simp add: mbta.aL_zero)
  using mbta.aL_zero apply blast
  subgoal for x t
  proof
    assume 1: "x ∈ while_program.While_program (*) neg_assert Continuous assertion (λp x . (p * x) ^ ⊗ * neg_assert p) (λx p y . p * x ⊔ neg_assert p * y) ∧ ascending_chain t ∧ tests.test_seq neg_assert t"
    have "x ∈ Continuous"
      apply (induct x rule: while_program.While_program.induct[where pre="λx y . wpt (x * y)" and while="λp x . ((p * x) ^ ⊗) * neg_assert p"])
      apply unfold_locales
      using 1 apply blast
      apply simp
      using mult_continuous apply blast
      apply (metis assertion_continuous mbta.test_expression_test mult_continuous neg_assertion sup_continuous)
      by (metis assertion_continuous dual_star_continuous mbta.test_expression_test mult_continuous neg_assertion)
    thus "x * complete_tests.Sum Sup t = complete_tests.Sum Sup (λn. x * t n)"
      using 1 by (smt continuous_dist_ascending_chain SUP_cong mbta.Sum_range)
  qed
  using wpt_def by auto

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_dual: box_hoare_valid where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and hoare_triple = "λp x q . wpb(x ^ o * q) ≤ p" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and Atomic_program = Continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot and Z = top
proof
  fix p x q t
  show "neg_assume q ≤ neg_assume p * neg_assume (x * neg_assume (neg_assume q)) ⟶ neg_assume q ⊓ whiledo.aL (λp x. (p * x) ^ ω * neg_assume p) (λx y. wpb (x ^ o * y)) 1 ≤ neg_assume (x ^ ω * neg_assume (neg_assume p))"
  proof
    let ?pt = "neg_assume p"
    let ?qt = "neg_assume q"
    assume "?qt ≤ ?pt * neg_assume (x * neg_assume ?qt)"
    also have "... ≤ x ^ o * ?qt ⊔ ?pt"
      by (smt assumption_sup_comp_eq sup_left_isotone mbta.zero_right_mult_decreasing mbta_dual.pre_def neg_assume_def neg_assumption sup.commute sup.left_commute sup.left_idem wpb_def)
    finally show "?qt ⊓ mbta_dual.aL ≤ neg_assume (x ^ ω * neg_assume ?pt)"
      by (smt dual_dual dual_omega_def dual_omega_greatest le_infI1 mbta_dual.a_d_closed mbta_dual.d_isotone mbta_dual.pre_def wpb_def)
  qed
  show "whiledo.aL (λp x. (p * x) ^ ω * neg_assume p) (λx y. wpb (x ^ o * y)) 1 = top ∨ whiledo.aL (λp x. (p * x) ^ ω * neg_assume p) (λx y. wpb (x ^ o * y)) 1 = 1"
    using mbta_dual.L_def mbta_dual.aL_one_circ mbta_dual.a_top by auto
  show "x ∈ while_program.While_program (*) neg_assume Continuous assumption (λp x. (p * x) ^ ω * neg_assume p) (λx p y. p * x ⊓ neg_assume p * y) ∧ ord.descending_chain (λx y. y ≤ x) t ∧ tests.test_seq neg_assume t ⟶ x * complete_tests.Prod Sup t = complete_tests.Prod Sup (λn. x * t n)"
  proof
    assume 1: "x ∈ while_program.While_program (*) neg_assume Continuous assumption (λp x . (p * x) ^ ω * neg_assume p) (λx p y . (p * x) ⊓ (neg_assume p * y)) ∧ ord.descending_chain greater_eq t ∧ tests.test_seq neg_assume t"
    have "x ∈ Continuous"
      apply (induct x rule: while_program.While_program.induct[where pre="λx y . wpb (x ^ o * y)" and while="λp x . ((p * x) ^ ω) * neg_assume p"])
      apply unfold_locales
      using 1 apply blast
      apply simp
      apply (simp add: mult_continuous)
      apply (metis assumption_continuous mbta_dual.test_expression_test mult_continuous neg_assumption inf_continuous)
      by (metis assumption_continuous omega_continuous mbta_dual.test_expression_test mult_continuous neg_assumption)
    thus "x * complete_tests.Prod Sup t = complete_tests.Prod Sup (λn. x * t n)"
      using 1 by (smt ord.descending_chain_def ascending_chain_def continuous_dist_ascending_chain SUP_cong mbta_dual.Prod_range)
  qed
  show "(wpb (x ^ o * q) ≤ p) = (neg_assume (x * neg_assume q) ≤ p)"
    by (simp add: mbta_dual.pre_def)
qed

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_pre_fix_dual: diamond_hoare_valid where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot) ⊔ 1" and diamond = "λx y . (x * y * bot) ⊔ 1" and hoare_triple = "λp x q . wpb(x * q) ≤ p" and ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and Atomic_program = Co_continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot and Z = top
  apply unfold_locales
  using mbta_dual.star_one mbta_pre_fix_dual.aL_one_circ apply simp
  using mbta_pre_fix_dual.aL_zero apply blast
  subgoal for x t
  proof
    assume 1: "x ∈ while_program.While_program (*) neg_assume Co_continuous assumption (λp x . (p * x) ^ * * neg_assume p) (λx p y . (p * x) ⊓ (neg_assume p * y)) ∧ ord.ascending_chain greater_eq t ∧ tests.test_seq neg_assume t"
    have "x ∈ Co_continuous"
      apply (induct x rule: while_program.While_program.induct[where pre="λx y . wpb (x * y)" and while="λp x . ((p * x) ^ * ) * neg_assume p"])
      apply unfold_locales
      using 1 apply blast
      apply simp
      apply (simp add: mult_co_continuous)
      apply (metis assumption_co_continuous mbta_dual.test_expression_test mult_co_continuous neg_assumption inf_co_continuous)
      by (metis assumption_co_continuous star_co_continuous mbta_dual.test_expression_test mult_co_continuous neg_assumption)
    thus "x * complete_tests.Sum Inf t = complete_tests.Sum Inf (λn. x * t n)"
      using 1 by (smt descending_chain_def ord.ascending_chain_def co_continuous_dist_descending_chain INF_cong mbta_dual.Sum_range)
  qed
  using wpb_def by auto

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_pre_fix: box_hoare_valid where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top) ⊓ 1" and diamond = "λx y . (x * y * top) ⊓ 1" and hoare_triple = "λp x q . p ≤ wpt(x ^ o * q)" and ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ℧) * neg_assert p" and Atomic_program = Co_continuous and Atomic_test = assertion and Z = bot
proof
  fix p x q t
  show "neg_assert p * neg_assert (x * neg_assert (neg_assert q)) ≤ neg_assert q ⟶ neg_assert (x ^ ℧ * neg_assert (neg_assert p)) ≤ neg_assert q ⊔ whiledo.aL (λp x. (p * x) ^ ℧ * neg_assert p) (λx y. wpt (x ^ o * y)) 1"
  proof
    let ?pt = "neg_assert p"
    let ?qt = "neg_assert q"
    assume 1: "?pt * neg_assert (x * neg_assert ?qt) ≤ ?qt"
    have "x ^ o * ?qt ⊓ ?pt ≤ ?pt * neg_assert (x * neg_assert ?qt)"
      by (smt (z3) inf.boundedI inf.cobounded1 inf.sup_monoid.add_commute le_infI2 inf_comp mbta.tests_dual.sub_commutative mbta.top_right_mult_increasing mbta_pre.pre_def mult.left_neutral mult_assoc top_comp wpt_def)
    also have "... ≤ ?qt"
      using 1 by simp
    finally have "(x ^ o) ^ ω * ?pt * top ≤ ?qt * top"
      using mbta.mult_left_isotone omega_least by blast
    hence "neg_assert (x ^ ℧ * neg_assert ?pt) ≤ ?qt"
      by (smt dual_omega_def inf_mono mbta.d_a_closed mbta.d_def mbta_pre.pre_def order_refl wpt_def mbta.a_d_closed)
    thus "neg_assert (x ^ ℧ * neg_assert ?pt) ≤ ?qt ⊔ mbta_pre_fix.aL"
      using le_supI1 by blast
  qed
  show "whiledo.aL (λp x. (p * x) ^ ℧ * neg_assert p) (λx y. wpt (x ^ o * y)) 1 = bot ∨ whiledo.aL (λp x. (p * x) ^ ℧ * neg_assert p) (λx y. wpt (x ^ o * y)) 1 = 1"
    using mbta.Omega_one mbta.a_top mbta_dual.vector_bot_closed mbta_pre_fix.aL_one_circ by auto
  show "x ∈ while_program.While_program (*) neg_assert Co_continuous assertion (λp x. (p * x) ^ ℧ * neg_assert p) (λx p y. p * x ⊔ neg_assert p * y) ∧ descending_chain t ∧ tests.test_seq neg_assert t ⟶ x * complete_tests.Prod Inf t = complete_tests.Prod Inf (λn. x * t n)"
  proof
    assume 1: "x ∈ while_program.While_program (*) neg_assert Co_continuous assertion (λp x . (p * x) ^ ℧ * neg_assert p) (λx p y . p * x ⊔ neg_assert p * y) ∧ descending_chain t ∧ tests.test_seq neg_assert t"
    have "x ∈ Co_continuous"
      apply (induct x rule: while_program.While_program.induct[where pre="λx y . wpt (x ^ o * y)" and while="λp x . ((p * x) ^ ℧) * neg_assert p"])
      apply unfold_locales
      using 1 apply blast
      apply simp
      apply (simp add: mult_co_continuous)
      apply (metis assertion_co_continuous mbta.test_expression_test mult_co_continuous neg_assertion sup_co_continuous)
      by (metis assertion_co_continuous dual_omega_co_continuous mbta.test_expression_test mult_co_continuous neg_assertion)
    thus "x * complete_tests.Prod Inf t = complete_tests.Prod Inf (λn. x * t n)"
      using 1 by (smt descending_chain_def co_continuous_dist_descending_chain INF_cong mbta.Prod_range)
  qed
  show "(p ≤ wpt (x ^ o * q)) = (p ≤ neg_assert (x * neg_assert q))"
    by (simp add: mbta_pre.pre_def)
qed

sublocale complete_mbt_algebra < mbta_dual: pre_post_spec_hoare where ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and Atomic_program = Continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot ..

sublocale complete_mbt_algebra < mbta_fix_dual: pre_post_spec_hoare where ite = "λx p y . (p * x) ⊓ (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and Atomic_program = Co_continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot ..

sublocale complete_mbt_algebra < mbta_pre: pre_post_spec_hoare where ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ⊗) * neg_assert p" and Atomic_program = Continuous and Atomic_test = assertion ..

sublocale complete_mbt_algebra < mbta_pre_fix: pre_post_spec_hoare where ite = "λx p y . (p * x) ⊔ (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ℧) * neg_assert p" and Atomic_program = Co_continuous and Atomic_test = assertion ..

end